У меня есть папка с 100 подпапками. В каждой подпапке есть до 4 таблиц Excel. Мне нужно войти в каждую подпапку и объединить 4 рабочих книги в 1 рабочую книгу с 4 рабочими таблицами.
Это код, с которого я начал. Но я должен вручную открывать каждую папку.
Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
Я пытался изменить список имен
fnameList = path ""
Но затем я получаю сообщение об ошибке «Ожидаемый массив Ubound»
Я бы хотел изменить это, чтобы автоматически заходить в папки и объединять файлы.
Я попробовал это ... я получил ошибку автоматизации на линии уничтожения
Option Explicit
Sub MergeExcelFiles()
Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Dim ofile As File
Dim MyPath As String, MyFile As String, File As Workbook
Dim fnameList, fnameCurFile As Variant
Dim countFiles As Long, countSheets As Long
Dim wksCurSheet As Worksheet
Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
Dim RootFolderName As String
RootFolderName = Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.ButtonName = "Select Root Folder"
If .Show <> -1 Then Exit Sub ' if OK is pressed
RootFolderName = .SelectedItems(1)
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
countFiles = 0
countSheets = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(RootFolderName)
For Each sf In f.SubFolders
Set wbkCurBook = Workbooks.Add 'this comes here so we add a new workbook in every folder
For Each ofile In sf.Files
If fso.GetExtensionName(ofile.path) Like "xls*" Then
countFiles = countFiles + 1
fnameCurFile = ofile.path
Debug.Print fnameCurFile
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Kill wbkSrcBook.FullName 'this will delete the workbook that was being copied
End If
Next
wbkCurBook.SaveAs sf.Name & "\" & "here the name of the workbook" 'this will save the file on the current folder.
Set wbkCurBook = Nothing 'reset the varaible
Next
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End Sub