Перемещение файлов согласно списку

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перемещение файлов согласно списку (Макросы/Sub)

Roman777

Дата: Среда, 25.03.2015, 15:49 | Сообщение № 1

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

Добрый день!
Решил написать макрос перемещения файлов, согласно списку в эксель файле. Тоесть есть папка с определённым количеством файлов, есть список, в котором указано имя некоторых файлов из той папки.
Используя труды здешних обитателей, получил следующий макрос:
[vba]

Код

Sub Сортировка1_перенос_файлов_по_перечню()
'раннее связывание, требуется ссылка на
'модель 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, NewFolder 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 NewFolder = .SelectedItems(1) Else Exit Sub
     End With
End If
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
          'проверка наличия файлов

          For i1 = 1 To n
              For Each fl In .Files
                    peremeshenie = 0
               '     MsgBox (Cells(StrokaOtsch, Stolbec).Value & Chr(13) & fl.Name)
                 If NameFile(i1) = fl.Name Then
                    kol = kol + 1
          '          MsgBox (FoldPth & fl.Name & Chr(13) & NewFolder)

                    peremeshenie = 1
                 End If
                    If peremeshenie = 1 Then
                       FSO.MoveFile FoldPth & fl.Name, FoldPth & NewFolder
                    End If
              Next fl
          Next i1
      End With
End With
Application.ScreenUpdating = True
MsgBox ("Количество перемещённых файлов :" & kol)
End Sub

[/vba]
Работает крайне долго, если файлов порядка 14 000, а в таблице около 5000 имён.
Можно ли это как-то исправить?
И ещё интересует, вот если поменять так код:

[vba]

Код

       For Each fl In .Files
              For i1 = 1 To n
                    peremeshenie = 0
               '     MsgBox (Cells(StrokaOtsch, Stolbec).Value & Chr(13) & fl.Name)
                 If NameFile(i1) = fl.Name Then
                    kol = kol + 1
          '          MsgBox (FoldPth & fl.Name & Chr(13) & NewFolder)

                    peremeshenie = 1
                 End If
                    If peremeshenie = 1 Then
                       FSO.MoveFile FoldPth & fl.Name, FoldPth & NewFolder
                    End If
              Next i1
          Next fl

[/vba]
Возможно ли исключение из цикла тех файлов, по которым перемещение уже произошло. Ато получается что внутренний цикл уже переместил файл, тобишь в исходном каталоге его уже нет. Внутренний цикл переходит на следующее повторение, а судя по внешнему циклу, мы будем искать тот файл который уже перемещён. Естественно - ошибка - файл не найден.

Код

Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Среда, 25.03.2015, 15:50