[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"

Пути пропишИте свои