VBS/WSH/JS - [решено] [VBS] Сортировка текстовых строк с учётом директорий

shadowbat · Отправлено: **13:46, 06-01-2020** | #11

megaloman,
во втором варианте сортировка чуть слетает и \f0\1.txt улетает наверх во время обработки out = (если f маленькая)
(в первом сообщении я разнорегистр не учёл и указал \F0\1.txt, нужно заменить на \f0\1.txt, чтобы были разнорегистровые пути)
вывод:

Код:

\f0\1.txt (!)
\f11.txt
\f22.txt
\f33.txt
\F0\
\F0\3.txt
\F0\2\
\F0\2\2.txt
\F1\
\F1\1.txt
\F111\
\F111\2.txt
\F111\222\
\F111\222\2.txt

для исправления нужно заменить после строки out = ""

Код:

If InStr(1, MasF(j), D) <> 0 Then

на

Код:

If InStr(1, LCase(MasF(j)), LCase(D)) <> 0 Then

megaloman · Отправлено: **15:22, 06-01-2020** | #12

shadowbat, Исправил. См. предыдущий пост. Не очень понятно, как у Вас такое вышло, что пути разнорегистровые, если данные не руками вбиты. Однозначно сортировка сломается, если, например, добавить строки
\F222\222.txt
\F000\000.txt
то есть, когда есть пути файлов, а путей к их папке нет

megaloman · Отправлено: **16:16, 06-01-2020** | #13

shadowbat,

Упростил код. Увы, кривой вариант

Код:

FileIn = "Z:\Box_In\filein.txt" FileOut = "Z:\Box_Out\fileout.txt" Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next With FSO.OpenTextFile(FileIn, 1, False) If Err.Number <> 0 Then MsgBox "File " + FileIn + vbCrLf + Err.Description + "(" + CStr(Err.Number) + ")" WScript.Quit 2 End If On Error GoTo 0 Alls = Split(.ReadAll, vbCrLf) .Close End With N = -1 For Each s In Alls N = N + 1 s = Trim(s) If Len(s) <> 0 Then If InStr(2, s, "\") = 0 Then s = "\" + Chr(1) + s Alls(N) = Replace(s, "\", Chr(0)) End If Next Call SortMas(Alls, N) out = "" For j = 0 To N If Alls(j) <> "" Then out = Alls(j) + vbCrLf + out Next out = Replace(out, Chr(0), "\") out = Replace(out, "\" + Chr(1), "") If Right(out, 2) = vbCrLf Then out = Mid(out, 1, Len(out) - 2) With FSO.CreateTextFile(FileOut, True) .Write out .Close End With MsgBox "Done" '''''''''''''''''''''''''''''''''''''End Sub SortMas(Mas, NMas) For i = 0 To NMas s = LCase(Mas(i)) For j = i To NMas ss = LCase(Mas(j)) If s < ss Then s = Mas(i) Mas(i) = Mas(j) Mas(j) = s s = LCase(Mas(i)) End If Next Next End Sub

shadowbat · Отправлено: **16:24, 06-01-2020** | #14

Цитата megaloman:

Упростил код. »

для информации - в этом варианте чуть другая сортировка (альтернативный вариант)
отличие ниже (может кому-то понадобится именно такая сортировка)

Скрытый текст

megaloman · Отправлено: **20:21, 06-01-2020** | #15

shadowbat,

Исправил

Код:

FileIn = "Z:\Box_In\filein.txt"
FileOut = "Z:\Box_Out\fileout.txt"

Set FSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

With FSO.OpenTextFile(FileIn, 1, False)
    If Err.Number <> 0 Then
        MsgBox "File   " + FileIn + vbCrLf + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 2
    End If
    On Error GoTo 0

    Alls = Split(.ReadAll, vbCrLf)
    .Close
End With

N = -1
For Each s In Alls
    N = N + 1
    s = Trim(s)
    If Len(s) <> 0 Then
        ii = InStrRev(s, "\")
        s = Mid(s, 1, ii - 1) + Replace(s, "\", "\" + Chr(0), ii)
        s = Replace(s, "\", Chr(1))
        Alls(N) = s
    End If
Next

Call SortMas(Alls, N)

out = ""
For j = 0 To N
    If Alls(j) <> "" Then out = Alls(j) + vbCrLf + out
Next
out = Replace(out, Chr(0), "")
out = Replace(out, Chr(1), "\")

If Right(out, 2) = vbCrLf Then out = Mid(out, 1, Len(out) - 2)

With FSO.CreateTextFile(FileOut, True)
    .Write out
    .Close
End With
MsgBox "Done"
'''''''''''''''''''''''''''''''''''''''''''End

Sub SortMas(Mas, NMas)
    For i = 0 To NMas
        s = LCase(Mas(i))
        For j = i To NMas
            ss = LCase(Mas(j))
            If s < ss Then
                s = Mas(i)
                Mas(i) = Mas(j)
                Mas(j) = s
                s = LCase(Mas(i))
            End If
        Next
    Next
End Sub

shadowbat · Отправлено: **09:55, 07-01-2020** | #16

megaloman, прекрасный код, максимально локаничный, обвязка даже больше места занимает, чем сама действующая часть

shadowbat · Отправлено: **19:36, 07-01-2020** | #17

Цитата megaloman:

Исправил »

вариант для массива и коллекции

Скрытый текст

Код:

Sub T()
Dim a(0 To 17)
a(0) = "\F0\"
a(1) = "\f0\1.txt"
a(2) = "\F0\2\"
a(3) = "\F0\2\2.txt"
a(4) = "\F0\3.txt"
a(5) = "\F1\"
a(6) = "C:\F111\333\"
a(7) = "C:\F111\22\3.txt"
a(8) = "\F1\1.txt"
a(9) = "\f11.txt"
a(10) = "\F111\"
a(11) = "\F111\2.txt"
a(12) = "\f111\222\"
a(13) = "\F111\222\2.txt"
a(14) = "\f22.txt"
a(15) = "\f33.txt"
a(16) = "\F222\222.txt"
a(17) = "\F000\000.txt"
a1 = a: a2 = a
Call DirA(a1, "Вверх"): Call DirA(a2, "Вниз")
Dim c1 As New Collection: Dim c2 As New Collection
For Each aa In a
i = i + 1
c1.Add CStr(aa), CStr(aa)
Next aa
Call CCopy(c1, c2)
Call DirC(c1, "Вверх"): Call DirC(c2, "Вниз")
For i = 1 To UBound(a1)
If a1(i - 1) <> c1(i) Then Stop
If a2(i - 1) <> c2(i) Then Stop
Next i
Stop
End Sub
Sub DirA(Alls, Optional П = "Вверх")
N = -1
For Each s In Alls
N = N + 1
s = Trim(s)
If Len(s) <> 0 Then
ii = InStrRev(s, "\")
s = Mid(s, 1, ii - 1) + Replace(s, "\", "\" + Chr(0), ii)
s = Replace(s, "\", Chr(1))
Alls(N) = s
End If
Next s
For i = LBound(Alls) To UBound(Alls)
s = LCase(Alls(i))
For j = i To UBound(Alls)
ss = LCase(Alls(j))
If s < ss Then
s = Alls(i)
Alls(i) = Alls(j): Alls(j) = s
s = LCase(Alls(i))
End If
Next j
Next i
N = -1: Alls2 = Alls
For Each s In Alls
N = N + 1
Alls(N) = Replace(Alls(N), Chr(0), ""): Alls(N) = Replace(Alls(N), Chr(1), "\")
Alls2(UBound(Alls2) - N) = Alls(N)
Next s
If П = "Вверх" Then Alls = Alls2
If П = "Вниз" Then Alls = Alls
End Sub
Sub DirC(Alls As Collection, Optional П = "Вверх")
Dim Alls2 As New Collection
N = 0
For Each s In Alls
N = N + 1
s = Trim(s)
If Len(s) <> 0 Then
ii = InStrRev(s, "\")
s = Mid(s, 1, ii - 1) + Replace(s, "\", "\" + Chr(0), ii)
s = Replace(s, "\", Chr(1))
Call CAdd(Alls, N, s)
End If
Next s
For i = 1 To Alls.Count
s = LCase(Alls(i))
For j = i To Alls.Count
ss = LCase(Alls(j))
If s < ss Then
s = Alls(i)
Call CAdd(Alls, i, Alls(j)): Call CAdd(Alls, j, s)
s = LCase(Alls(i))
End If
Next j
Next i
N = 0: Call CCopy(Alls, Alls2)
Call CReplace(Alls, Chr(0), ""): Call CReplace(Alls, Chr(1), "\")
For N = 1 To Alls.Count
Call CAdd(Alls2, Alls2.Count - N + 1, Alls(N))
Next N
If П = "Вверх" Then Call CCopy(Alls2, Alls)
'If П = "Вниз" Then Call CCopy(Alls, Alls)
End Sub
Sub CAdd(col As Collection, nu, zn)
col.Add zn, , , nu
col.Remove nu
End Sub
Sub CCopy(col1 As Collection, col2 As Collection)
Set col2 = New Collection
For Each x In col1
col2.Add CStr(x), CStr(x)
Next x
End Sub
Sub CReplace(col As Collection, r1, r2)
For i = 1 To col.Count
r = Replace(col(i), r1, r2)
col.Add r, , , i
col.Remove i
Next i
End Sub

+ защита

Код:

If Left(s, 1) <> "\" And Mid(s, 2, 2) <> ":\" Then s = "\" & s

megaloman · Отправлено: **20:07, 07-01-2020** | #18

shadowbat,

Не знаю, зачем нужно делать для массива, но я бы его определил вот так:

Код:

a = Array("\F0\", _
        "\f0\1.txt", _
        "\F0\2\", _
        "\F0\2\2.txt", _
        "\F0\3.txt", _
        "\F1\", _
        "C:\F111\333\", _
        "C:\F111\22\3.txt", _
        "\F1\1.txt", _
        "\f11.txt", _
        "\F111\", _
        "\F111\2.txt", _
        "\f111\222\", _
        "\F111\222\2.txt", _
        "\f22.txt", _
        "\f33.txt", _
        "\F222\222.txt", _
        "\F000\000.txt")

MsgBox a(0) + vbCrLf + a(UBound(a))

shadowbat · Отправлено: **22:22, 08-01-2020** | #19

если кто-то будет в дальнейшем пользоваться:
SortMas это узкое горлышко из-за метода пузырька
на 70 000 файлах ориентировочное время исполнения 1 час - огромное число для такого "небольшого" количества файлов
в DirC для коллекций, к примеру, та же сортировка должна выполняться ещё дольше - 390 часов (из-за перемножения операций 70 000 x 70 000) (один прогон 70000 раз занимает 20 секунд)
нужно обязательно менять метод пузырька на любой другой.
(даже хотя бы через выгрузку на лист (в две колонки обычную и lcase) + родную сортировку ActiveSheet.Sort по lcase + загрузку назад)

megaloman · Отправлено: **22:36, 08-01-2020** | #20

shadowbat, А Вы не говорили, что это VBA в Excel, это стльно меняет дело. Колитесь, откуда берутся строки и куда они деваются потом. Почему надо сохранять регистр - внутри сортировки любое лишнее действие ест много времени