Добрый день!
Когда то наткнулся на этот макрос для перемещения файлов с одной папки в другую исходя списка!
Вот сейчас понадобился, а он что то не работает - запускается, указываю данные, а вот в итоге ничего не находит, как я только не крутил!
Подскажите, пожалуйста, в чем может быть причина? Сам в этих делах не силен!(
Заранее спасибо!
Вот сам макрос:
Когда то наткнулся на этот макрос для перемещения файлов с одной папки в другую исходя списка!
Вот сейчас понадобился, а он что то не работает - запускается, указываю данные, а вот в итоге ничего не находит, как я только не крутил!
Подскажите, пожалуйста, в чем может быть причина? Сам в этих делах не силен!(
Заранее спасибо!
Вот сам макрос:
Код |
---|
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 |