Sub Сортировка2_перенос_файлов_по_перечню2()
'раннее связывание, требуется ссылка на
'модель Windows Script Host Object Model
Dim i As Long
Dim ActWB As Workbook
Dim avInp(), FSO As FileSystemObject, fl As File
Dim Stolbec As Integer
Dim StrokaOtsch As Integer
Dim NameFile() As String
Dim FoldPth, NewFolder1, NewFolder As String
Dim ki As Long
Dim Fiyli() As String

Application.ScreenUpdating = False
i1_n = Cells(Rows.Count, 3).End(xlUp).Row
Set ActWB = ActiveWorkbook

NewFolder = Application.InputBox("Укажите имя папки, в которую необходимо перенести файлы", "Имя новой папки", _
"Файлы из списка")
Stolbec = Application.InputBox("Укажите номер столбца, в котором находятся наименования файлов", "Номер столбца", _
"8")
StrokaOtsch = Application.InputBox("Укажите номер строки, в которой находится шапка таблицы", _
"Номер строки", "1")

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Папка для работы с файлами"
    .ButtonName = "Select": .AllowMultiSelect = False
    If .Show Then FoldPth = .SelectedItems(1) Else Exit Sub
End With

If NewFolder = "" Then
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Папка файлов по списку"
        .ButtonName = "Select": .AllowMultiSelect = False
    If .Show Then NewFolderPath = .SelectedItems(1) Else: Exit Sub
    End With
Else
NewFolderPath = FoldPth & NewFolder
End If

Time_1 = Timer
If Right(NewFolder, 1) <> "\" Then NewFolder = NewFolder & "\"
If Right(FoldPth, 1) <> "\" Then FoldPth = FoldPth & "\"

ReDim NameFile(i1_n - StrokaOtsch)
For i1 = 1 To i1_n - StrokaOtsch
    If Cells(StrokaOtsch + i1, Stolbec) <> "" Then
    n = n + 1
    NameFile(n) = Cells(StrokaOtsch + i1, Stolbec)
    End If
Next i1
ReDim Preserve NameFile(n)
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
        If Not .FolderExists(FoldPth & NewFolder) Then .CreateFolder FoldPth & NewFolder
        'создание каталога
    With .GetFolder(FoldPth)
        If .Files.Count = 0 Then MsgBox "Файлов в указанном пути не найдено", 48: Exit Sub
        'проверка наличия файлов
        
        ReDim Fiyly(.Files.Count)
            For Each fl In .Files
                ki = ki + 1
                Fiyly(ki) = fl.Name
            Next fl
        
            For i = 1 To UBound(Fiyly)
            For i1 = 1 To n
                If Fiyly(i) = NameFile(i1) Then
                kol = kol + 1
                FSO.MoveFile FoldPth & NameFile(i1), NewFolderPath
                End If
            Next i1
            Next i
    End With
End With
time_ = Time_1 - Timer
Time_delta = Format(time_ / 24 / 60 / 60, "hh\ч mm\м ss\с")
Application.ScreenUpdating = True
MsgBox ("Выполнено за " & Time_delta & Chr(13) & "Количество перемещённых файлов :" & kol)
End Sub