Question

我正在尝试遍历用户指定文件夹的子文件夹中的所有Excel文件，并将数据复制并粘贴到名为“编译”的新工作簿中。此代码可以完成创建和保存新工作簿的工作，但是数据不会复制并粘贴到工作簿中。

有人可以帮忙吗？

Sub LoopCopyPasteSubfolders()

Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FdrPicker
    .Title = "Select a Target Folder"
    .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        MyPath = .SelectedItems(1) & "\"
    End With

NextCode:
'in case of cancel
If MyPath = "" Then GoTo ResetSettings Else

Dim NewWB As Workbook
Set NewWB = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Batch\Compilation.xlsx", FileFormat:=xlWorkbookNormal

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)
Set subfolder = folder.subfolders
For Each subfolder In folder.subfolders
Set wb = subfolder.Files

 For Each wb In subfolder.Files
    If fso.GetExtensionName(wb.Path) = "*.xls*" Then
    Workbooks.Open wb, ReadOnly:=True
    Range("A1:M1").End(xlDown).Copy
    For Each cell In Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells   
        If IsEmpty(cell) = True Then cell.PasteSpecial Paste:=xlPasteValues
        'exit when value pasted to the first empty row

        Exit For
    Next cell
End If

Next wb

Next subfolder  

'reset settings to default    
ResetSettings:

Application.ScreenUpdating = True    
Application.EnableEvents = True    
Application.DisplayAlerts = True

End Sub

Answer 1

尝试以下代码：我对您的代码进行了一些更改。

Sub LoopCopyPasteSubfolders()

Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Dim wba As Workbook

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FdrPicker
    .Title = "Select a Target Folder"
    .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        MyPath = .SelectedItems(1) & "\"
    End With

NextCode:
'in case of cancel
If MyPath = "" Then GoTo ResetSettings Else

Dim NewWB As Workbook
Set NewWB = Workbooks.Add

NewWB.SaveAs Filename:="C:\Batch\Compilation.xlsx", FileFormat:=xlWorkbookNormal

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)

For Each subfolder In folder.subfolders

    For Each wb In subfolder.Files
        If fso.GetExtensionName(wb.Path) = "*.xls*" Then
            Set wba = Workbooks.Open(wb.Path & "\" & wb.FullName, , True)
                wba.Worksheets(1).Range("A1:M20").Copy
                For Each cell In NewWB("Compilation").Worksheets("Sheet1").Columns(1).Cells
                    If IsEmpty(cell) = True Then 
                       cell.PasteSpecial Paste:=xlPasteValues
                    'exit when value pasted to the first empty row

                       Exit For
                    End If
                Next cell
            wba.Close False
            NewWB.Save

    Next wb

Next subfolder

'reset settings to default
ResetSettings:

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

如果抛出错误，请尝试调试并注释您所处的行。

Answer 2

这是完成代码，它遍历用户选择的文件夹中的所有子文件夹，并将子文件夹中任何Excel文件中的数据复制并粘贴到新工作簿中。

Sub LoopCopyPasteSubfoldersIII()

Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Dim wba As Workbook
Dim wbn As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = 
Application.FileDialog(msoFileDialogFolderPicker)

With FdrPicker
.Title = "Select a Target Folder"
.AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    MyPath = .SelectedItems(1) & "\"
End With

NextCode:
'in case of cancel
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings Else

Dim NewWB As Workbook
Set NewWB = Workbooks.Add

NewWB.SaveAs Filename:="C:\Users\405458\Downloads\Compilation.xlsx", 
FileFormat:=xlWorkbookNormal

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)

For Each subfolder In folder.subfolders

For Each wb In subfolder.Files
    If fso.GetExtensionName(wb.Path) = "xlsx" Then
        wbn = fso.GetAbsolutePathName(wb)
        Set wba = Workbooks.Open(Filename:=wbn)

   ActiveWorkbook.Worksheets(1).Range("A1:M1").Select
            Range(Selection, Selection.End(xlDown)).Copy
            For Each cell In Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells
                If IsEmpty(cell) = True Then
                   cell.PasteSpecial Paste:=xlPasteValues
                'exit when value pasted to the first empty row
                Exit For
                Else
                End If
            Next cell
        wba.Close False
        NewWB.Save
    End If
Next wb

Next subfolder

'reset settings to default
ResetSettings:

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

循环浏览子文件夹中的Excel文件，并将数据复制并粘贴到一张纸上

2 个答案: