Всем привет
Был макрос, который объединял все файлы.
Был макрос, который перебирал папки
А как сделать, чтобы макрос искал файлы с определенной маской и объединял их (например маска файла -магазин)
то есть берется файл, ищется во всех папках по маске и объединяется, если маска совпадает
Никак не могу как это сделать
Был макрос, который объединял все файлы.
Был макрос, который перебирал папки
А как сделать, чтобы макрос искал файлы с определенной маской и объединял их (например маска файла -магазин)
то есть берется файл, ищется во всех папках по маске и объединяется, если маска совпадает
Никак не могу как это сделать
Код |
---|
Const FRow& = 5 ' Номер строки начала сбора данных (ниже шапки) Const Sborka$ = "Сборка.xls" ' Имя сборочного файла Dim FCol&, LCol& ' Переменные номеров первого и последнего столбца для сбора данных Dim LRow&, LRow_Cel& Dim wb_Cel As Workbook, wb_Tek As Workbook Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet Dim MyPath$, MyFileName$, MyFulName$ Dim Uslovie1 As Boolean ' Выбор папки With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Укажите рабочую папку": .Show If .SelectedItems.Count = 0 Then Exit Sub MyPath = .SelectedItems(1) & "\" End With Set myobject = CreateObject("Scripting.FileSystemObject") Set mysource = myobject.GetFolder(MyPath) For Each mySubFolder In mysource.SubFolders Set mysource = myobject.GetFolder(mySubFolder.Path) For Each MyFile In mysource.Files MyFileName = Dir(mysource & "\*.xls*") ''' Do Something with files in sub folders Uslovie1 = False Do Until MyFileName = "" If MyFileName <> ThisWorkbook.Name Then MyFulName = mysource & "\" & MyFileName Workbooks.Open Filename:=MyFulName, UpdateLinks:=0 If Not Uslovie1 Then Set wb_Cel = ActiveWorkbook Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & Sborka, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False Uslovie1 = True Else Set wb_Tek = ActiveWorkbook For Each Sh_Cel In wb_Cel.Sheets With Sh_Cel FCol = .UsedRange.Cells(1, 1).Column LCol = .UsedRange.Columns.Count + FCol - 1 LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1 End With For Each Sh_Tek In wb_Tek.Sheets If Sh_Tek.Name = Sh_Cel.Name Then With Sh_Tek LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row If LRow >= FRow Then .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1) End If End With With Sh_Cel Range(.Cells(LRow_Cel, 2 + LCol - FCol), .Cells(LRow_Cel + LRow - FRow, 2 + LCol - FCol)) = MyFulName End With End If Next Sh_Tek Next Sh_Cel Workbooks(MyFileName).Close SaveChanges:=False End If End If MyFileName = Dir Loop Next Next |