将数据从多个工作簿复制并粘贴到另一个工作簿中的工作表中

我希望你能帮上忙。 我目前有一段代码见下面。 我想要做的是让用户select包含工作簿的文件夹。 然后打开每个工作簿，从每个工作簿中select一个名为“SearchCaseResults”的工作表，将数据从第二行中的每个“SearchCaseResults”复制到最后一个使用的行，并将这些数据粘贴到名为“Disputes”的工作表中另一个文件夹

所以在PIC 1你可以看到三个工作簿英格兰，England_2和England_3这些工作簿中的每一个包含一个工作表“SearchCaseResults”所以我基本上需要的代码是循环通过文件夹打开英格兰工作簿select工作表“SearchCaseResults”复制数据在此工作表中从第2行到最后一个已用行，然后粘贴到另一个工作簿中的“Disputes”工作表，在另一个文件夹中，然后select下一个工作簿England_2select工作簿“SearchCaseResults”在此工作簿中复制此工作表上的数据2最后使用的行然后粘贴在“争议”工作表中从以前的工作表（英国）复制的数据，然后继续此复制和粘贴过程，直到文件夹中没有更多的工作簿。

目前我的代码是打开工作簿，这是很好的，select/激活“SearchCaseResults”工作表，但它只是应对单元格A2来自英国工作表，然后它只是粘贴从最后的数据（我怀疑以前的工作表中的数据正在被粘贴）我的代码可以修改成从A2的每个“SearhCaseResults”工作表复制数据到上次使用的行，然后粘贴到每个下方的“Disputes”工作表其他。

这是我的代码迄今任何和所有的帮助，非常感谢。

码

Sub LoopAllExcelFilesInFolder() 'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 'SOURCE: www.TheSpreadsheetGuru.com Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet\" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.xls*" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) 'Loop through each Excel file in folder Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Ensure Workbook has opened before moving on to next line of code DoEvents 'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook Dim lRow As Long Dim ws2 As Worksheet lRow = Range("A" & Rows.Count).End(xlUp).Row Set y = Workbooks.Open("C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet") Set ws2 = y.Sheets("Disputes") wb.Worksheets("SearchCasesResults").Range("A2" & lRow).Copy With y ws2.Range("A2").PasteSpecial End With 'Save and Close Workbook wb.Close SaveChanges:=True 'Ensure Workbook has closed before moving on to next line of code DoEvents 'Get next file name myFile = Dir Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 

我应该指出，上面的代码是从一个单独的工作簿中运行一个命令button。

见图2

图1

图2

Answer 1

尝试这个。 我纠正了一些语法错误。 目前还不清楚你是否只是复制了我所假设的A列的数据，但是如果没有复制的话就需要修改。

 Sub LoopAllExcelFilesInFolder() 'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 'SOURCE: www.TheSpreadsheetGuru.com Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog Dim lRow As Long Dim ws2 As Worksheet Dim y As Workbook 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet\" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.xls*" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) Set y = Workbooks.Open("C:\Users\CONNELLP\Desktop\Claire Macro\Copy and Paste Disputes\Report Sheet") Set ws2 = y.Sheets("Disputes") 'Loop through each Excel file in folder Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook With wb.Sheets("SearchCaseResults") lRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) End With wb.Close SaveChanges:=True 'Get next file name myFile = Dir Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub