Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Скриптовые языки администрирования Windows (http://forum.oszone.net/forumdisplay.php?f=102)
-   -   [решено] [VBS] Сортировка текстовых строк с учётом директорий (http://forum.oszone.net/showthread.php?t=343549)

shadowbat 05-01-2020 14:03 2903627
[VBS] Сортировка текстовых строк с учётом директорий
 
Есть текстовые строки (именно строки, а не пути к существующим файлам)
Код:
\F1\1.txt
\F111\2.txt
\f11.txt
\f33.txt
\f22.txt
\F0\3.txt
\F0\1.txt
\F0\2\2.txt
\F1\
\F0\
\F0\2\
\F111\
Если их просто отсортировать по алфавиту, то получится
Код:
\F0\
\F0\1.txt
\F0\2\
\F0\2\2.txt
\F0\3.txt
\f11.txt
\F111\
\F111\2.txt
\F1\
\F1\1.txt
\f22.txt
\f33.txt
Но нужно отсортировать их с учетом директорий, (сначала файлы в корне текущего каталога, потом подкаталоги) чтобы получилось так:
Код:
\f11.txt
\f22.txt
\f33.txt
\F0\
\F0\1.txt
\F0\3.txt
\F0\2\
\F0\2\2.txt
\F1\
\F1\1.txt
\F111\
\F111\2.txt
либо наоборот, подкаталоги, потом файлы.
Код:
\F0\
\F0\2\
\F0\2\2.txt
\F0\1.txt
\F0\3.txt
\F1\
\F1\1.txt
\F111\
\F111\2.txt
\f11.txt
\f22.txt
\f33.txt
либо любым подобным образом, только не по алфавиту, а по директориям
Как это сделать? есть решение или алгоритм? это должна быть рекурсивная функция? через split("\") ?

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

набросок для переменных
Код:
Dim a(1 To 12)
a(1) = "\F1\1.txt"
a(2) = "\F111\2.txt"
a(3) = "\f11.txt"
a(4) = "\f33.txt"
a(5) = "\f22.txt"
a(6) = "\F0\3.txt"
a(7) = "\F0\1.txt"
a(8) = "\F0\2\2.txt"
a(9) = "\F1\"
a(10) = "\F0\"
a(11) = "\F0\2\"
a(12) = "\F111\"

megaloman 05-01-2020 14:54 2903632
shadowbat, в списке только один символ (f или F) и он одинаковый во всех строках , или вместо него может быть смесь символов перед цифрами и они могут в разных строках свои?

shadowbat 05-01-2020 15:08 2903633
Цитата:
вместо него может быть смесь символов перед цифрами и они могут в разных строках свои?
всё как в реальной жизни, может быть и f и F и русские и английские и юникод.
это парсинг реальных путей файлов, но в виде строк, соответственно имена могут быть такие же как у реальных директорий и файлов - самые различные
сам пока пишу на split() и ubound(split())

очень предварительный и полуправильный вариант


Код:
Sub Sort()
Dim a(): ReDim a(1 To 12)
a(1) = "\F1\1.txt"
a(2) = "\F111\2.txt"
a(3) = "\f11.txt"
a(4) = "\f33.txt"
a(5) = "\f22.txt"
a(6) = "\F0\3.txt"
a(7) = "\F0\1.txt"
a(8) = "\F0\2\2.txt"
a(9) = "\F1\"
a(10) = "\F0\"
a(11) = "\F0\2\"
a(12) = "\F111\"
'сортировка
a(1) = "\F0\"
a(2) = "\F0\1.txt"
a(3) = "\F0\2\"
a(4) = "\F0\2\2.txt"
a(5) = "\F0\3.txt"
a(6) = "\f11.txt"
a(7) = "\F111\"
a(8) = "\F111\2.txt"
a(9) = "\F1\"
a(10) = "\F1\1.txt"
a(11) = "\f22.txt"
a(12) = "\f33.txt"
For Each aa In a
kol = UBound(Split(aa, "\")): If kol > max Then max = kol
Next aa
Call Sort1(a, 0, max)
Stop
End Sub
Sub Sort1(a, l, max)
For Each aa In a
kol = UBound(Split(aa, "\"))
If kol = l Then Debug.Print aa
Next aa
If l <= max Then Call Sort1(a, l + 1, max)
End Sub

megaloman 05-01-2020 21:12 2903665
не по алфавиту, а по директориям
Код:
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
ND = -1
NF = -1
For Each s In Alls
    N = N + 1
    s = Trim(s)
    Alls(N) = s
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then ND = ND + 1 Else NF = NF + 1
    End If
Next

ReDim MasD(ND), MasF(NF)
jD = -1
jF = -1
For i = 0 To N
    s = Alls(i)
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then
            jD = jD + 1
            MasD(jD) = Replace(LCase(Alls(i)), "\", Chr(0))
        Else
            jF = jF + 1
            MasF(jF) = Replace(LCase(Alls(i)), "\", Chr(0))
        End If
    End If
Next
Set Alls = Nothing

For i = 0 To ND
    For j = i To ND
        If MasD(i) < MasD(j) Then
            s = MasD(i)
            MasD(i) = MasD(j)
            MasD(j) = s
        End If
    Next
Next

For i = 0 To NF
    For j = i To NF
        If MasF(i) < MasF(j) Then
            s = MasF(i)
            MasF(i) = MasF(j)
            MasF(j) = s
        End If
    Next
Next

out = ""
For i = 0 To ND
    D = MasD(i)
    For j = 0 To NF
        If InStr(1, MasF(j), D) <> 0 Then
            out = MasF(j) + vbCrLf + out
            MasF(j) = ""
        End If
    Next
    out = D + vbCrLf + out
Next

For j = 0 To NF
    If MasF(j) <> "" Then out = MasF(j) + vbCrLf + out
Next
out = Replace(out, Chr(0), "\")
'MsgBox out  '''''''''''''''''''''''

With FSO.CreateTextFile(FileOut, True)
    .Write out
    .Close
End With
MsgBox "Done"
Пути пропишИте свои

shadowbat 05-01-2020 22:31 2903690
megaloman, работает
замена "\" на Chr(0) изящная, действительно AscW("\") мешает сравнивать строки, т.к. у него номер ниже/выше чем у алфавита
а также выдаёт все строки в LCase регистре, что всё-таки является изменением, а не только сортировкой (понимаю, что без LCase сортировка в текущем виде не сработает, но факт остается фактом - после этой функции нужно производить дальнейшие действия со строками только в нижнем регистре, либо дополнительно восстанавливать изначальный регистр после функции)

Iska 06-01-2020 01:43 2903711
shadowbat, а можете рассказать, для чего Вам потребен список именно в таком виде?

shadowbat 06-01-2020 02:48 2903714
Цитата:
Цитата Iska
для чего Вам потребен список именно в таком виде? »
в сортированном? для сравнения директорий, которым частично принадлежат те или иные строки

Iska 06-01-2020 03:12 2903716
shadowbat, спасибо, ясно.

shadowbat 06-01-2020 03:52 2903717
Цитата:
Цитата megaloman
не по алфавиту, а по директориям »
добавил восстановление регистра, только нужно закоментить 'Set Alls = Nothing
подразумевается, что изначально в строках не было разнорегистровых дублей, иначе оба дубля получат одинаковый регистр (либо нижний либо изначальный)
исправил лишнее добавление пустой строки в конце нового файла
добавить после MsgBox out: и сохранение в файл соответственно заменить на out3
Код:
out2 = Split(out, vbCrLf)
For i = LBound(out2) To UBound(out2)
For j = LBound(Alls) To UBound(Alls)
If out2(i) = LCase(Alls(j)) Then out2(i) = Alls(j)
Next j
Next i
For i = LBound(out2) To UBound(out2) - 1
If out3 = "" Then out3 = out2(i) Else out3 = out3 + vbCrLf + out2(i)
Next
'MsgBox out3

megaloman 06-01-2020 09:45 2903728
Цитата:
Цитата 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
ND = -1
NF = -1
For Each s In Alls
    N = N + 1
    s = Trim(s)
    Alls(N) = s
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then ND = ND + 1 Else NF = NF + 1
    End If
Next

ReDim MasD(ND), MasF(NF)
jD = -1
jF = -1
For i = 0 To N
    s = Alls(i)
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then
            jD = jD + 1
            MasD(jD) = Replace(Alls(i), "\", Chr(0))
        Else
            jF = jF + 1
            MasF(jF) = Replace(Alls(i), "\", Chr(0))
        End If
    End If
Next
Set Alls = Nothing

Call SortMas(MasD, ND)
Call SortMas(MasF, NF)

out = ""
For i = 0 To ND
    D = LCase(MasD(i))
    For j = 0 To NF
        If InStr(1, LCase(MasF(j)), D) <> 0 Then
            If out = "" Then out = MasF(j) Else out = MasF(j) + vbCrLf + out
            MasF(j) = ""
        End If
    Next
    If out = "" Then out = MasD(i) Else out = MasD(i) + vbCrLf + out
Next

For j = 0 To NF
    If MasF(j) <> "" Then out = MasF(j) + vbCrLf + out
Next
out = Replace(out, Chr(0), "\")
'MsgBox out  '''''''''''''''''''''''

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 06-01-2020 13:46 2903766
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 06-01-2020 15:22 2903779
shadowbat, Исправил. См. предыдущий пост. Не очень понятно, как у Вас такое вышло, что пути разнорегистровые, если данные не руками вбиты. Однозначно сортировка сломается, если, например, добавить строки
\F222\222.txt
\F000\000.txt
то есть, когда есть пути файлов, а путей к их папке нет

megaloman 06-01-2020 16:16 2903784
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 06-01-2020 16:24 2903786
Цитата:
Цитата megaloman
Упростил код. »
для информации - в этом варианте чуть другая сортировка (альтернативный вариант)
отличие ниже (может кому-то понадобится именно такая сортировка)
Скрытый текст

megaloman 06-01-2020 20:21 2903808
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 07-01-2020 09:55 2903870
megaloman, прекрасный код, максимально локаничный, обвязка даже больше места занимает, чем сама действующая часть

shadowbat 07-01-2020 19:36 2903947
Цитата:
Цитата 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 07-01-2020 20:07 2903953
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 08-01-2020 22:22 2904104
если кто-то будет в дальнейшем пользоваться:
SortMas это узкое горлышко из-за метода пузырька
на 70 000 файлах ориентировочное время исполнения 1 час - огромное число для такого "небольшого" количества файлов
в DirC для коллекций, к примеру, та же сортировка должна выполняться ещё дольше - 390 часов (из-за перемножения операций 70 000 x 70 000) (один прогон 70000 раз занимает 20 секунд)
нужно обязательно менять метод пузырька на любой другой.
(даже хотя бы через выгрузку на лист (в две колонки обычную и lcase) + родную сортировку ActiveSheet.Sort по lcase + загрузку назад)

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

shadowbat 08-01-2020 22:58 2904110
Цитата:
Цитата megaloman
shadowbat, А Вы не говорили, что это VBA в Excel»
да, не уточнил, в шаблоне заголовка нет VBA, поэтому поставил VBS, а в самой теме не уточнил

Цитата:
Цитата megaloman
, это сильно меняет дело. Колитесь, откуда берутся строки и куда они деваются потом. »
как упоминал выше, сравниваю дерево файлов и подкаталогов в двух похожих папках, чтобы выявить какие файлы отсутствуют, или изменены или равны.
строки берутся из FSO, который загоняет их в коллекцию простым прогоном по всему дереву (Dir не понимает юникод в именах)
далее две коллекции с деревьями объединяются, отрезается начальный каталог, убираются дубли, остаётся коллекция с уникальными строками из обеих папок (в первом сообщении первый код под фразой "Есть текстовые строки:")
Цитата:
Цитата megaloman
Почему надо сохранять регистр - внутри сортировки любое лишнее действие ест много времени »
сохранять регистр необходимо, потому что регистр есть в именах файлов и изменять изначальный регистр считаю неприемлемым, тем более что конкретно это действие влияет на скорость, но 15% от пары минут это немного.
учитывать разный регистр необходимо, потому что в одной папке может быть \Folder\File1.txt , а в другой \FOLDER\file1.txt , в Windows это один и тот же путь, а при обработке строка "\Folder\File1.txt" не равна "\FOLDER\file1.txt", поэтому и сортируем через lcase, а результат выдаём в оригинальном регистре

да и к тому же этот переключатель регистра легко можно настроить.
на самом деле их два. 1. сортировка с учетом регистра (или без учета) и 2. выдача результата в оригинальном регистре или в нижнем/верхнем
это всё кому как удобнее и на метод пузырька не влияет

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

вообще, во всей этой теме гениальные строки с заменой слеша на Chr(0) и подстановка перед файлом Chr(1), что позволяет сортировать строки любым обычным способом, который подходит для сортировки текста и делать любую обвязку кому как удобнее, это не предмет спора вообще

megaloman 08-01-2020 23:29 2904112
shadowbat, Подозреваю, сортировка не нужна вовсе. По голому имени нельзя узнать, файлы или изменены или равны. Надо четкая постановка. Возможно, есть готовый софт для этого. И зачем при сравнении наличия файлов надо перечислять имена директорий? Почему не ограничиться только полными именами файлов?

shadowbat 08-01-2020 23:35 2904113
Цитата:
Цитата megaloman
Подозреваю, сортировка не нужна вовсе. »
для сравнения технически не нужна, но визуально нужна. с таким же успехом можно сказать, что любая сортировка текста не нужна т.к. все равно найти значение в тексте можно и без сортировки

Цитата:
Цитата megaloman
По голому имени нельзя узнать, файлы или изменены или равны. Надо четкая постановка. Возможно, есть готовый софт для этого. »
конечно нельзя, всё остальное и не являлось вопросом темы.
вопрос был конкретно по сортировке директорий, представленных в виде строк.
несколько разных готовых .exe софтов для сравнения двух папок, конечно, тоже существует на просторах интернета.
часто подаётся под соусом "синхронизация", что, по мне, является совершенно отдельной задачей. например существует сравнение текстовых и бинарных файлов, но не существует синхронизации файлов, потому что впихивать содержимое одного файла в другой никому не приходит в голову

Цитата:
Цитата megaloman
И зачем при сравнении наличия файлов надо перечислять имена директорий? Почему не ограничиться только полными именами файлов? »
ведь существует много разных вариантов формирования списков файлов
у каких то людей/программ только файлы, у иных и файлы и папки, а может у кого-то список только папок. сортировка только файлов без учёта папок является полумерой
это как сортировать строки текста без учёта спец символов !@№;%:?, не во всех же строках они имеются, зачем их учитывать при сортировке?

Iska 09-01-2020 00:43 2904120
shadowbat, ну, вот, я как-то вполне обхожусь Far Manager'ом с парой-тройкой плагинов плюс внешним CloneSpy для покрытия всего спектра своих задач по полуавтоматическому сравнению каталогов и файлов.

Для сортировки строк, занимающей длительное время, есть смысл применять либо System.Collections.ArrayList/System.Collections.Sortedlist из .Net (возможно, потребуется однократно зарегистрировать библиотеку), либо базу данных в памяти.

iglezz 09-01-2020 00:47 2904122
Цитата:
Цитата shadowbat
как упоминал выше, сравниваю дерево файлов и подкаталогов в двух похожих папках, чтобы выявить какие файлы отсутствуют, или изменены или равны.
строки берутся из FSO, который загоняет их в коллекцию простым прогоном по всему дереву (Dir не понимает юникод в именах)
далее две коллекции с деревьями объединяются, отрезается начальный каталог, убираются дубли, остаётся коллекция с уникальными строками из обеих папок »
Мне кажется, что оптимальнее будет (особенно на 70000 файлов) в процессе прогона по дереву заниматься отсевом, сортировкой и пополнением списка.

shadowbat 19-01-2020 03:40 2905734
К сожалению при выгрузке на лист есть две проблемы:
1. Chr(0) не обрабатывается, и обрезается, таким образом вместо Chr(0) Chr(1) необходимо использовать например Chr(1) Chr(2)
2. Родная сортировка Exl не учитывает символы Chr(0-31), таким образом Chr(0) и Chr(1) нужно заменить на любой другой (невстречающийся) набор печатных символов с номером >31 согласно таблице ascii, например &0& и &1& , в идеале нужно использовать любые "неправильные" символы \ / : * ? " < > |

megaloman 20-01-2020 19:41 2905958
Вложений: 1
shadowbat, Пробуйте, интересно, быстрее сортировка?

shadowbat 22-01-2020 10:26 2906232
Цитата:
Цитата megaloman
Пробуйте, интересно, быстрее сортировка? »
1. в FileIn ограничение в 65536 строк. если сделать 66000 строк, то при выполнении строки RR.Value = WorksheetFunction.Transpose(Alls) на лист записываются значения #Н/Д (после ~3000-10000 ячейки, точное число зависит от суммы длин строк в FileIn)
2. в цикле For i = N1 + 1 To N2 идёт накопление и Exl ненадолго подвисает на примерно i=16000-25000 (возможно точное число зависит от конфигурации машины), если добавить строку If i Mod 1000 = 0 Then Debug.Print i , то видно как скорость печати постепенно уменьшается до (Не отвечает). при этом в диспетчере задач видно, что Exl продолжает работать и в конечном итоге отвисает. 65000 строк сортирует за 2-3 минуты, что конечно быстрее прошлого значения
3. при сохранении 65000 длинных строк со средней длиной 50 была ошибка. на строке .Write SS при работе с 65000 строками выдал "Ошибка: Run-time error '5': Invalid procedure call or argument", если строк меньше, то сохраняет нормально. если 65000 коротких (!) строк, то тоже сохраняет нормально. со средней длиной строк 30 сохранил нормально, если средняя длина строк 50, то ошибку выдает. может быть влияет не длина строк, а какие-то символы в пути, пока неизвестно

скопировал код из архива:
я200120.xlsm.rar
Код:
Sub rrr()

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

Rang1 = "C2"
R1 = Range(Rang1).Row
C1 = Range(Rang1).Column

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 = LBound(Alls) - 1
NN = -1
For Each s In Alls
    s = Trim(s)
    If Len(s) <> 0 Then
        N = N + 1
        NN = NN + 1
        ii = InStrRev(s, "\")

        s = Mid(s, 1, ii - 1) + Replace(s, "\", "**", ii)
        s = Replace(s, "\", "*")

        Alls(N) = s
    End If
Next

Set RR = Range(Cells(R1, C1), Cells(R1 + NN, C1))
RR.Value = WorksheetFunction.Transpose(Alls)
Erase Alls

ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(Rang1), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Лист3").Sort
    .SetRange RR
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Alls = RR

N1 = LBound(Alls, 1)
N2 = UBound(Alls, 1)

s = Alls(N1, 1)
s = Replace(Replace(s, "**", "\"), "*", "\")
Alls(N1, 1) = s
SS = s

For i = N1 + 1 To N2
    s = Alls(i, 1)
    s = Replace(Replace(s, "**", "\"), "*", "\")
    Alls(i, 1) = s
    SS = SS + vbCrLf + s
Next

RR.Value = Alls

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

End Sub

megaloman 22-01-2020 21:12 2906341
shadowbat, Происследовал затраты времени на исполнение этапов макроса. Выяснил, что накапливать очень длинную строку - это катастрофа по времени.
Вот изменённый макрос
Код:
Sub rrr()

FileIn = "Z:\Box_In\fileinRND.txt"
FileOut = "Z:\Box_Out\fileoutRND.txt"

Rang1 = "C2"        'C какой ячейки нечинаются данные
Rang1 = "D1"

TTT = Timer

R1 = Range(Rang1).Row
C1 = Range(Rang1).Column
 
With CreateObject("VBScript.RegExp")
    .Pattern = "[0-9]"
    .IgnoreCase = True
    .Global = True
    NameCol = .Replace(Rang1, "")
End With

Columns(NameCol).ClearContents

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
On Error GoTo 0
 
N = LBound(Alls) - 1
NN = -1
For Each S In Alls
    S = Trim(S)
    If Len(S) <> 0 Then
        N = N + 1
        NN = NN + 1
        ii = InStrRev(S, "\")

        S = Mid(S, 1, ii - 1) + Replace(S, "\", Chr(42) + Chr(42), ii)
        S = Replace(S, "\", Chr(42))
       
        Alls(N) = S
    End If
Next

ReDim Alls2(1 To NN + 1, 1 To 1)
For i = 1 To NN + 1
    Alls2(i, 1) = Alls(i - 1)
Next
Erase Alls

Set RR = Range(Cells(R1, C1), Cells(R1 + NN, C1))
RR.Value = Alls2
Erase Alls2

'MsgBox "Посадили файл в таблицу (sec) " + CStr(Timer - TTT)
TTT1 = Timer

ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(Rang1), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
With ActiveWorkbook.ActiveSheet.Sort
    .SetRange RR
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'MsgBox "Отсортировали (sec) " + CStr(Timer - TTT1)
TTT1 = Timer

Alls = RR

'MsgBox "Забрали отсорт в массив (sec) " + CStr(Timer - TTT1)
TTT1 = Timer

N1 = LBound(Alls, 1)
N2 = UBound(Alls, 1)

With FSO.CreateTextFile(FileOut, True)
    For i = N1 To N2
        Alls(i, 1) = Replace(Replace(Alls(i, 1), Chr(42) + Chr(42), "\"), Chr(42), "\")
        If i < N2 Then
            .WriteLine Alls(i, 1)
        Else
            .Write Alls(i, 1)
        End If
    Next
    .Close
End With

RR.Value = Alls
'MsgBox "Done (sec) " + CStr(Timer - TTT1) + "    (" + CStr(Timer - TTT) + ")"
MsgBox "Done (sec) " + CStr(Timer - TTT)

End Sub

Sub GenOut()
    FileOut = "Z:\Box_In\fileinRND.txt"
    NRepeat = 2000
   
    TTT = Timer
   
    Dim Sim(61)
   
    S = ""
    i = 0
    For j = 1 To 3
        If j = 1 Then k1 = 48: k2 = 57
        If j = 2 Then k1 = 65: k2 = 90
        If j = 3 Then k1 = 97: k2 = 122
       
        For k = k1 To k2
            Sim(i) = Chr(k)
            S = S + Sim(i) '+ vbCrLf
            i = i + 1
        Next
    Next
   
   
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.CreateTextFile(FileOut, True)
   
    For i = 1 To NRepeat
            ''''''''''  MsgBox sRND(1, 5, Sim)  ' 1,5 - диапазон кол-ва симв в сформир строке; Sim - масс символов
        If (i - 1) Mod 100 = 0 Then sTotal = "\" + sRND(6, 8, Sim) + ".txt" Else sTotal = ""
        S1 = sRND(3, 5, Sim)
        S2 = sRND(3, 5, Sim)
        S3 = sRND(3, 5, Sim)

        T1 = sRND(2, 5, Sim) + ".txt"
        T2 = sRND(2, 5, Sim) + ".txt"
        T3 = sRND(2, 5, Sim) + ".txt"
   
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + S3 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + S3 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + S3 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + S1 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + S1 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + S1 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + S2 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + S2 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + S2 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + S3 + "\"
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + S1 + "\"
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + S2 + "\"
       
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + S2 + "\"
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + S3 + "\"
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + S1 + "\"
     
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S1 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S2 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + T1
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + T2
        sTotal = sTotal + vbCrLf + "\" + S3 + "\" + T3
       
        sTotal = sTotal + vbCrLf + "\" + S1 + "\"
        sTotal = sTotal + vbCrLf + "\" + S2 + "\"
        sTotal = sTotal + vbCrLf + "\" + S3 + "\"
        .WriteLine sTotal
    Next
    .Close
End With
MsgBox "Done (sec) " + CStr(Timer - TTT)

End Sub

Function nRND(min1, max1)
    nRND = Int((max1 - min1 + 1) * Rnd + min1)
End Function

Function sRND(min1, max1, SSS)
    nSim = UBound(SSS)
    sRND = ""
    For j = 1 To nRND(min1, max1)
        sRND = sRND + SSS(nRND(0, nSim))
    Next
End Function
Макрос берёт в массив текстовый файл с прописанными в нём путями, помещает данные в таблицу, в таблице сортирует, записывает в выходной файл. Переписал транспонирование массива - Excel не справлялся.
Был вынужден сделать макрос для генерации текстового файла со случайными путями - надо было на чём-то измываться. Он выделен зелёным - он нужен, чтобы сфабриковать исходный файл для обработки, собственно для обработки файла он не нужен. Он формирует 72019строк (при значении параметра NRepeat = 2000)
Если заархивируете и отдадите свой файл - поизмываюсь и над ним.

Iska 22-01-2020 21:42 2906350
Цитата:
Цитата megaloman
Выяснил, что накапливать очень длинную строку - это катастрофа по времени. »
Угу. Память хоть и оперативная, но сотни тысяч операций конкатенации строк (а это, фактически — выделение новой памяти; создание в ней нового экземпляра строки — даже если используется одна и та же переменная к коде; освобождение памяти, занятой старой строкой/строками) бывают весьма затратны на «больших» строках.

shadowbat 22-01-2020 22:25 2906361
megaloman,
время работы моментальное
теряется одна строка, нужно заменить For i = 1 To NN на For i = 1 To NN + 1

с этим макросом плавающая ошибка №3 уже не возникает, №1 и №2 также исправлены

сформировать свой файл можно через bat
Код:
C:
cd windows
dir /b /s > D:\list.txt


Время: 00:32.

Время: 00:32.
© OSzone.net 2001-