Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Перемещение файлов согласно списку - Мир MS Excel

Старая форма входа
  • Страница 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
 
Ответить
СообщениеДобрый день!
Решил написать макрос перемещения файлов, согласно списку в эксель файле. Тоесть есть папка с определённым количеством файлов, есть список, в котором указано имя некоторых файлов из той папки.
Используя труды здешних обитателей, получил следующий макрос:
[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:49
RAN Дата: Среда, 25.03.2015, 16:50 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
[vba]
Код
arr=[a1:a100].value
for i=1 to ubound(arr)
if FSO.fileexists(arr(i,1)) then FSO.MoveFile arr(i,1), FoldPth & NewFolder
next
[/vba]

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Среда, 25.03.2015, 16:50
 
Ответить
Сообщение[vba]
Код
arr=[a1:a100].value
for i=1 to ubound(arr)
if FSO.fileexists(arr(i,1)) then FSO.MoveFile arr(i,1), FoldPth & NewFolder
next
[/vba]
Автор - RAN
Дата добавления - 25.03.2015 в 16:50
Roman777 Дата: Среда, 25.03.2015, 16:55 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Спасибо, RAN, Подскажите пожалуйста, что означает эта запись?
[vba]
Код
arr=[a1:a100].value
[/vba].
И что такое 1 в arr(i,1), ато я чёт дуб дубом?

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

Сообщение отредактировал Roman777 - Среда, 25.03.2015, 17:06
 
Ответить
СообщениеСпасибо, RAN, Подскажите пожалуйста, что означает эта запись?
[vba]
Код
arr=[a1:a100].value
[/vba].
И что такое 1 в arr(i,1), ато я чёт дуб дубом?
Автор - Roman777
Дата добавления - 25.03.2015 в 16:55
Roman777 Дата: Среда, 25.03.2015, 17:12 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
RAN, Спасибо ещё раз. Код действительно работает гораздо быстрее. Получается что программа быстрее определит существование файла, чем сравнит его имя с именем из таблицы?

Много чего не знаю!!!!
 
Ответить
СообщениеRAN, Спасибо ещё раз. Код действительно работает гораздо быстрее. Получается что программа быстрее определит существование файла, чем сравнит его имя с именем из таблицы?
Автор - Roman777
Дата добавления - 25.03.2015 в 17:12
RAN Дата: Среда, 25.03.2015, 17:42 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Нет, не быстрее.
Но значительно быстрее, чем проделает это 14000*5000 раз. :D

Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеНет, не быстрее.
Но значительно быстрее, чем проделает это 14000*5000 раз. :D
Автор - RAN
Дата добавления - 25.03.2015 в 17:42
Roman777 Дата: Четверг, 26.03.2015, 09:31 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Возможно ли такое перемещение файлов без использования FSO ? и на сколько это прибавит производительности?

Много чего не знаю!!!!
 
Ответить
СообщениеВозможно ли такое перемещение файлов без использования FSO ? и на сколько это прибавит производительности?
Автор - Roman777
Дата добавления - 26.03.2015 в 09:31
Roman777 Дата: Четверг, 26.03.2015, 09:39 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
RAN, Но разве при проверке на существование, программе не приходится так же искать из 14000 файлов существующие 5000? и всё-равно получается при цикле по 5000 наименованиям, он каждое имя выискивает в 14000 файлах и определяет его существование, разве нет?

Много чего не знаю!!!!
 
Ответить
СообщениеRAN, Но разве при проверке на существование, программе не приходится так же искать из 14000 файлов существующие 5000? и всё-равно получается при цикле по 5000 наименованиям, он каждое имя выискивает в 14000 файлах и определяет его существование, разве нет?
Автор - Roman777
Дата добавления - 26.03.2015 в 09:39
Roman777 Дата: Пятница, 27.03.2015, 15:03 | Сообщение № 8
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Хотел добавить, что я чуть-чуть изменил принцип, я все имена файлов сначала забил в массив, и после уже делал тож самое что в своём самом первом варианте (сравнение массивов). Результат - работает гораздо быстрее даже чем метод FSO.Fileexists. Только вчера понял что операции с массивами гораздо быстрее работают, чем с файлами...)
Результат:
[vba]
Код
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, 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")

Time_1 = Timer
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
         'проверка наличия файлов
          
         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), FoldPth & NewFolder
                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
[/vba]
Перенёс мне 5092 фотки за 10 секунд дето..)

Много чего не знаю!!!!
 
Ответить
СообщениеХотел добавить, что я чуть-чуть изменил принцип, я все имена файлов сначала забил в массив, и после уже делал тож самое что в своём самом первом варианте (сравнение массивов). Результат - работает гораздо быстрее даже чем метод FSO.Fileexists. Только вчера понял что операции с массивами гораздо быстрее работают, чем с файлами...)
Результат:
[vba]
Код
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, 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")

Time_1 = Timer
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
         'проверка наличия файлов
          
         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), FoldPth & NewFolder
                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
[/vba]
Перенёс мне 5092 фотки за 10 секунд дето..)
Автор - Roman777
Дата добавления - 27.03.2015 в 15:03
RAN Дата: Пятница, 27.03.2015, 16:58 | Сообщение № 9
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Цитата Roman777, 27.03.2015 в 15:03, в сообщении № 8
Time_1 = Timer
With Application.FileDialog(msoFileDialogFolderPicker)

Солдат спит, служба идет. hands lol

Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение
Цитата Roman777, 27.03.2015 в 15:03, в сообщении № 8
Time_1 = Timer
With Application.FileDialog(msoFileDialogFolderPicker)

Солдат спит, служба идет. hands lol
Автор - RAN
Дата добавления - 27.03.2015 в 16:58
RAN Дата: Пятница, 27.03.2015, 17:01 | Сообщение № 10
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Цитата Roman777, 27.03.2015 в 15:03, в сообщении № 8
NewFolder = Application.InputBox("Укажите имя папки, в которую необходимо перенести файлы", "Имя новой папки", _
"Файлы из списка")
.................................

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


Вообще песня. yahoo

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Пятница, 27.03.2015, 17:02
 
Ответить
Сообщение
Цитата Roman777, 27.03.2015 в 15:03, в сообщении № 8
NewFolder = Application.InputBox("Укажите имя папки, в которую необходимо перенести файлы", "Имя новой папки", _
"Файлы из списка")
.................................

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


Вообще песня. yahoo
Автор - RAN
Дата добавления - 27.03.2015 в 17:01
Roman777 Дата: Пятница, 27.03.2015, 17:28 | Сообщение № 11
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
RAN, Весело...) ну хоть бы прокоментировали понятно. Я шутки не понимаю. Ранее почему-то это не казалось Вам смешным.
Знаю в ВБА оч мало, поэтому наверное кажется так неуклюже. Тем не менее, код работает так, как мне нужно).

Много чего не знаю!!!!
 
Ответить
СообщениеRAN, Весело...) ну хоть бы прокоментировали понятно. Я шутки не понимаю. Ранее почему-то это не казалось Вам смешным.
Знаю в ВБА оч мало, поэтому наверное кажется так неуклюже. Тем не менее, код работает так, как мне нужно).
Автор - Roman777
Дата добавления - 27.03.2015 в 17:28
RAN Дата: Пятница, 27.03.2015, 19:18 | Сообщение № 12
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Комментирую.
1. Вы включаете секундомер, и идете из раздевалки к линии старта. Бежите 100 метров. На финише выключаете секундомер. За сколько вы пробежали 100 метров? Может есть смысл включить на старте?
2. При отсутствии папки новая папка добавляется в диалоге.
Ну, и, до кучи, измерять время работы макроса секундами, это почти то-же, что измерять остаток бензина в баке легковушки ведрами.

PS раньше не обращал внимания. На таймере зацепился.

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Пятница, 27.03.2015, 19:24
 
Ответить
СообщениеКомментирую.
1. Вы включаете секундомер, и идете из раздевалки к линии старта. Бежите 100 метров. На финише выключаете секундомер. За сколько вы пробежали 100 метров? Может есть смысл включить на старте?
2. При отсутствии папки новая папка добавляется в диалоге.
Ну, и, до кучи, измерять время работы макроса секундами, это почти то-же, что измерять остаток бензина в баке легковушки ведрами.

PS раньше не обращал внимания. На таймере зацепился.
Автор - RAN
Дата добавления - 27.03.2015 в 19:18
Roman777 Дата: Пятница, 27.03.2015, 21:13 | Сообщение № 13
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
RAN, Ещё раз спасибо!
Блин, всё моя невнимательность. А я подумал, что я что-то совсем не там использую, думал что ограничения тут какие-то в FSO... из-за Вашей реакции. С таймером, Вы правы не туда поставил, но вроде потом же исправлял... по-ходу сюда не ту версию макроса копирнул. А вот с диалоговым окном, я задумывал, что если имя папки стереть, можно было бы папку для переносимых файлов назначить. Но тут действительно выглядит неправильно. Вроде подправил ошибки:
[vba]
Код
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
[/vba]
ПС,на моём мелком экране крайне трудно читать такой код. А как тут все делают "разворачивающийся список" для кода?

Много чего не знаю!!!!
 
Ответить
СообщениеRAN, Ещё раз спасибо!
Блин, всё моя невнимательность. А я подумал, что я что-то совсем не там использую, думал что ограничения тут какие-то в FSO... из-за Вашей реакции. С таймером, Вы правы не туда поставил, но вроде потом же исправлял... по-ходу сюда не ту версию макроса копирнул. А вот с диалоговым окном, я задумывал, что если имя папки стереть, можно было бы папку для переносимых файлов назначить. Но тут действительно выглядит неправильно. Вроде подправил ошибки:
[vba]
Код
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
[/vba]
ПС,на моём мелком экране крайне трудно читать такой код. А как тут все делают "разворачивающийся список" для кода?
Автор - Roman777
Дата добавления - 27.03.2015 в 21:13
ShAM Дата: Суббота, 28.03.2015, 03:48 | Сообщение № 14
Группа: Друзья
Ранг: Старожил
Сообщений: 1347
Репутация: 249 ±
Замечаний: 0% ±

Excel 2010
Цитата Roman777, 27.03.2015 в 21:13, в сообщении № 13
А как тут все делают "разворачивающийся список" для кода?
Для этого есть кнопочка "spoiler".
 
Ответить
Сообщение
Цитата Roman777, 27.03.2015 в 21:13, в сообщении № 13
А как тут все делают "разворачивающийся список" для кода?
Для этого есть кнопочка "spoiler".
Автор - ShAM
Дата добавления - 28.03.2015 в 03:48
andrik0110 Дата: Воскресенье, 05.02.2017, 20:17 | Сообщение № 15
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Добрый день!
Народ,помогите!
Взял этот код Romana777, а VBA при пошаговом запуске начинает ругаться вот на эту строчку
'Dim avInp(), FSO As FileSystemObject, fl As File
Ругается так: User-defined type not defined
Подскажите, что нужно исправить?

Все, разобрался. Нужно в VBA ч/з меню Tools->References подключить Windows Script Host Object Model.
Может для чайников конечно (каковым я и являюсь), но может кому-то время сэкономит.


Сообщение отредактировал andrik0110 - Воскресенье, 05.02.2017, 22:24
 
Ответить
СообщениеДобрый день!
Народ,помогите!
Взял этот код Romana777, а VBA при пошаговом запуске начинает ругаться вот на эту строчку
'Dim avInp(), FSO As FileSystemObject, fl As File
Ругается так: User-defined type not defined
Подскажите, что нужно исправить?

Все, разобрался. Нужно в VBA ч/з меню Tools->References подключить Windows Script Host Object Model.
Может для чайников конечно (каковым я и являюсь), но может кому-то время сэкономит.
Автор - andrik0110
Дата добавления - 05.02.2017 в 20:17
Roman777 Дата: Понедельник, 06.02.2017, 11:02 | Сообщение № 16
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
andrik0110, Дело в том, что объект FileSystemObject содержится в библиотеке Scrrun.Dll. По умолчанию она у Вас не включена. Включить её можно в окне VBA->Tools-> References-> напротив "Microsoft Scripting Runtime" установить галочку.
Тогда ругаться на неопознанный объект не будет.

Ну и вообще не обязательно так очевидно подключать библиотеку. Можно создать объект немного по-другому даже с выключенной галкой (вродебы поздним связыванием такой приём называют):

[vba]
Код
Sub Сортировка2_перенос_файлов_по_перечню2()

Dim i As Long
Dim ActWB As Workbook
Dim avInp(),  fl As Object
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

Set FSO = CreateObject("Scripting.FileSystemObject") 'FSO определяю тут по-другому

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
[/vba]

Много чего не знаю!!!!
 
Ответить
Сообщениеandrik0110, Дело в том, что объект FileSystemObject содержится в библиотеке Scrrun.Dll. По умолчанию она у Вас не включена. Включить её можно в окне VBA->Tools-> References-> напротив "Microsoft Scripting Runtime" установить галочку.
Тогда ругаться на неопознанный объект не будет.

Ну и вообще не обязательно так очевидно подключать библиотеку. Можно создать объект немного по-другому даже с выключенной галкой (вродебы поздним связыванием такой приём называют):

[vba]
Код
Sub Сортировка2_перенос_файлов_по_перечню2()

Dim i As Long
Dim ActWB As Workbook
Dim avInp(),  fl As Object
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

Set FSO = CreateObject("Scripting.FileSystemObject") 'FSO определяю тут по-другому

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
[/vba]
Автор - Roman777
Дата добавления - 06.02.2017 в 11:02
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перемещение файлов согласно списку (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!