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