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

Copy and paste data from multiple workbooks to a worksheet in another Workbook

提问by Philip Connell

I hope you can help. I currently have a piece of code see below. What I would like it to do is allow a user to select folder that contains workbooks. Then open each workbook select a sheet named "SearchCaseResults" from each workbook copy the data from each "SearchCaseResults" from the 2nd row down to the last used row, and paste this data into a worksheet called "Disputes" located in a different workbook in another folder.

我希望你能帮忙。我目前有一段代码，见下文。我希望它做的是允许用户选择包含工作簿的文件夹。然后打开每个工作簿，从每个工作簿中选择一个名为“SearchCaseResults”的工作表，将每个“SearchCaseResults”中的数据从第二行复制到最后使用的行，然后将此数据粘贴到位于不同工作簿中的名为“Disputes”的工作表中另一个文件夹。

So in PIC 1 you can see three Workbooks England, England_2 and England_3 each of these workbooks contain a worksheet "SearchCaseResults" So what I essentially need the code to do is loop through the folder open England workbook select the worksheet "SearchCaseResults" copy the data on this worksheet from row 2 to last used row then paste to the "Disputes" worksheet in the other workbook, in another folder, then select the next Workbook England_2 select the worksheet "SearchCaseResults" in this workbook copy the data on this worksheet from row 2 to last used row then PASTE IT BELOWthe data copied from the previous worksheet(England) in the "Disputes" Worksheet and then continue with this copy and paste process until there are no more Workbooks left in the folder.

因此，在 PIC 1 中，您可以看到三个 Workbooks England、England_2 和 England_3，这些工作簿中的每一个都包含一个工作表“SearchCaseResults”所以我基本上需要代码做的是遍历文件夹打开 England 工作簿选择工作表“SearchCaseResults”复制数据在此工作表上从第 2 行到最后使用的行，然后粘贴到另一个工作簿中的“争议”工作表，在另一个文件夹中，然后选择下一个工作簿 England_2 选择此工作簿中的工作表“SearchCaseResults”从行复制此工作表上的数据2 到最后使用的行，然后将其粘贴到“争议”工作表中从上一个工作表（英格兰）复制的数据下方，然后继续此复制和粘贴过程，直到文件夹中没有更多工作簿。

At the moment the code I have is opening up the workbooks, which is fine and selecting/activating the "SearchCaseResults" worksheet from each, but it is only coping cell A2 from the England sheets and then it is just pasting the data from the last sheet into the destination Worksheet.(I suspect the data from previous sheets is being pasted over) Can my code be amended to copy the data from each "SearhCaseResults" sheet from A2 to last used row and then Pasted into "Disputes" sheet underneath each other.

目前，我拥有的代码正在打开工作簿，这很好，可以从每个工作簿中选择/激活“SearchCaseResults”工作表，但它只是处理英格兰工作表中的单元格 A2，然后它只是粘贴最后一个的数据工作表到目标工作表中。（我怀疑以前工作表中的数据被粘贴了）我的代码可以修改以将每个“SearhCaseResults”表中的数据从 A2 复制到最后使用的行，然后粘贴到每个表下方的“争议”表中其他。

Here is my code so far as always any and all help is greatly appreciated.

到目前为止，这是我的代码，非常感谢所有帮助。

CODE

代码

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

I should point out that the code above is run from a separate workbook with a command button.

我应该指出，上面的代码是从带有命令按钮的单独工作簿中运行的。

See pic 2

见图2

PIC 1

图 1

PIC 2

图2

采纳答案by SJR

Try this. I have corrected a few syntax errors. It's not clear if you are just copying data from column A, which I have assumed, but if not the copy line will need to be amended.

尝试这个。我纠正了一些语法错误。不清楚您是否只是从我假设的 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