Перемещение файлов в каталоги с совпадающим началом в именах

'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• 
' Перемещение выбранных файлов в папки с тем же началом в имени, 
' если под этот критерий подходит только одна папка в получателе 

' Параметры: 
'  1) %WL 
'  2) "<путь назначения>" 
'  3) <число первых совпавших символов> (при отсутствии вводим в окне) 
'  4) <максимальное число символов> (0 - отключить; при отсутствии - в окне) 

' Примеры: 
'  1) %WL C:\Тест 
'  2) %WL "%T" 3 0 
'  3) %WL "%T" "" 6 
'  4) %WL "%T" 5 20 

' Автор - Flasher © 
'••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• 
With WScript.Arguments 
  C = .Count : If C = 0 Then WScript.Quit 
  On Error Resume Next 
  List = .Item(0) : Path = .Item(1) 
  If C < 3 Then 
    Num = "" : Chek Num, "" 
  Else 
    Num = .Item(2) : If Len(.Item(2)) = 0 Then Chek Num, "" 
  End If 
  If C < 4 Then 
    Max = "" : Chek Max, "МАКСИМАЛЬНОЕ " 
  Else 
    Max = .Item(3) : If Max = 0 Then Max = Num 
  End If 
  On Error Goto 0 
  If C < 2 Then : MsgBox "Укажите не менее 2-ух параметров!", 4144, _ 
  "Рассортировка файлов по папкам" : WScript.Quit : End if 
End With : If Right(Path, 1) <> "\" Then Path = Path & "\" 

Sub Chek(Count, Word) 
  L = vbNewline 
  Do Until IsNumeric(Count) 
    Count = InputBox(L&L&L&L&L& "Введите " & Word & "число первых" & _ 
    " символов в именах:", "Рассортировка файлов по папкам", 3) 
    If Trim(Count) = "" Then WScript.Quit 
  Loop 
End Sub 

Set FSO = CreateObject("Scripting.FileSystemObject") 
Set SbF = FSO.GetFolder(Path).SubFolders 
Set NSp = CreateObject("Shell.Application").NameSpace(Path) 
For Each F in Split(FSO.GetFile(List).OpenAsTextStream(1, -1).ReadAll, vbNewline) 
  If F > vbNullString Then 
    If FSO.FileExists(F) Then 
      For i = Num to Max 
        Start = Left(FSO.GetBaseName(F), i) : Set Items = NSP.Items 
        Items.Filter 32, Start & "*" 
        If Items.Count = 1 Then 
          For Each FF in SbF 
            If StrComp(Start, Left(FSO.GetFileName(FF), i), 1) = 0 Then 
              FSO.MoveFile F, FF & "\" : Exit For 
            End If 
          Next 
        End If : Set Items = Nothing 
      Next 
    End If 
  End If 
Next : Set FSO = Nothing : Set NSP = Nothing : Set SbF = Nothing : WScript.Quit