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

[shadowbat]

Есть текстовые строки (именно строки, а не пути к существующим файлам)

\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]

shadowbat, в списке только один символ (f или F) и он одинаковый во всех строках , или вместо него может быть смесь символов перед цифрами и они могут в разных строках свои?

[shadowbat]

вместо него может быть смесь символов перед цифрами и они могут в разных строках свои?
всё как в реальной жизни, может быть и 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]

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]

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

[Iska]

shadowbat, а можете рассказать, для чего Вам потребен список именно в таком виде?

[shadowbat]

для чего Вам потребен список именно в таком виде? »
в сортированном? для сравнения директорий, которым частично принадлежат те или иные строки

[Iska]

shadowbat, спасибо, ясно.

[shadowbat]

не по алфавиту, а по директориям »
добавил восстановление регистра, только нужно закоментить '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]

добавил восстановление регистра ... исправил лишнее добавление пустой строки »
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]

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]

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

[megaloman]

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]

Упростил код. »
для информации - в этом варианте чуть другая сортировка (альтернативный вариант)
отличие ниже (может кому-то понадобится именно такая сортировка)
https://d.radikal.ru/d10/2001/24/575b6056c543.png

[megaloman]

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]

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

[shadowbat]

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

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]

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]

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

[megaloman]

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