В статье мы рассмотрим вопрос отбора электронных файлов (например Word) по отфильтрованной таблице Excel.
Для чего это нужно? Например ваши коллеги присылают огромное количество файлов, которые даже могут быть сгруппированы по различным параметрам и разложены соответственно по разным папкам. Но вам внезапно поставили задачу отобрать из них несколько файлов (например докладов на сегодня или резюме сотрудников).
Чтобы сделать это вручную Вам нужно запускать поиск файла, задавать названия этих файлов и т.д) или просто открывать каждую папку, находить в ней нужный файл, копировать его и вставлять в новую папку.
Так как в нашем случае записей немного, его можно решить и в ручную. А если записей несколько десятков, сотен или тысяч?
С помощью программирования вам достаточно будет отфильтровать свою таблицу Excel и и нажать на кнопку для запуска макроса, который самостоятельно создаст новую папку, найдет нужные файлы и скопирует их в созданную папку.
Алгоритм работы кода будет следующий:
1. Создайте на своем компьютере папку с названием "Тест". В этой папке создайте новый файл Excel и добавьте в него таблицу как на первом рисунке этой статьи. Затем создайте в этой же папке новую папку "Каталоги", в которой создайте несколько папок со следующими именами: "1000", "2000", "4000" и "5000". В них, в свою очередь создайте файлы с расширением ".docx" и именами, соответствующими значениям ячеек во втором столбце созданной таблицы в Excel.
2. Дополнительно создайте папку "Новая выборка файлов" в которую будут копироваться файлы.
2. Отфильтруйте таблиц. Я в своем примере отфильтровал записи по полю субъекты РФ (выбрал Камчатский край). Вид таблицы как на рисунке № 2.
3. Откройте редактор VBA с помощью комбинации клавиш Alt+F11 и в области ввода кода наберите и скопируйте из статьи и вставьте туда следующий код.
Sub КопированиеФайла()
Dim ws As Worksheet, r As Range
Dim FLDR As String
Dim i As Long
Dim strWB As String
Dim strF As String
Dim FSO As Object
Set ws = ActiveSheet
Set r = ws.UsedRange
strWB = ThisWorkbook.Path & "\Новая выборка файлов" ' это папка для копий отобранных файлов
'====================================
With Application.FileDialog(msoFileDialogFolderPicker)' эта часть кода для служебного окна выбора папки, из которой будут копироваться файлы
.Show
FLDR = .SelectedItems(1) & "\" ' папка в которой будем искать все файлы
End With
'===================================
Set FSO = CreateObject("Scripting.FileSystemObject") ' специальная переменная для работы VBA с файловой системой
For i = 2 To r.Rows.Count
If ws.Cells(i, 1).EntireRow.Hidden = False Then
strF = ws.Cells(i, 2)
Search FSO.GetFolder(FLDR), strF, strWB ' здесь мы запускаем функцию, которая будет искать в выбранной папке нужные файлы
End If
Next i
End Sub
и вторая часть кода
Sub Search(Fold As Object, strF As String, strWB As String)
Dim SubFold As Object, Fil As Object
Dim Fname As String
Dim FSO As Object
Dim objFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo ErrHandle
For Each SubFold In Fold.SubFolders
Search SubFold, strF, strWB
Next SubFold
For Each Fil In Fold.Files ' здесь мы получаем все файлы в папке
Fname = Right(Fil, Len(Fil) - InStrRev(Fil, "\"))' здесь из полного пути в имени файла оставляем только его наименование и расширение
If Fname = strF & ".docx" Or Fname = strF & ".doc" Or Fname = strF & ".pptx" Then ' здесь мы сравниваем полученное имя файла с полем "Код" в таблице Excel и при их соответствии, копируем файл в папку "Новая выборка файлов"
Set objFile = FSO.GetFile(Fil)
objFile.Copy strWB & "\"
End If
Next Fil
Exit Sub
ErrHandle:
MsgBox "Нет допуска к папке! """ & Fold.Path & """"
Err.Clear
End Sub
Теперь при запуске первой процедуры (КопированиеФайла) VBA начнет искать в выбранной вами папке файлы, имеющие в своем имени значение поля "Код" и найденные файлы копировать в папку "Новая выборка файлов".