将多个工作簿中的数据复制并粘贴到另一个工作簿中的工作表中 [英] Copy and paste data from multiple workbooks to a worksheet in another Workbook

问题描述

希望您能提供帮助。我目前有一段代码见下文。我希望它允许用户选择包含工作簿的文件夹。然后打开每个工作簿，从每个工作簿中选择一个名为 SearchCaseResults的工作表，将来自第二行的每个 SearchCaseResults中的数据从第二行向下复制到最后使用的行，并将此数据粘贴到位于另一工作簿中的名为 Disputes的工作表中。另一个文件夹。

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.

因此，在PIC 1中，您可以看到三个工作簿England，England_2和England_3，每个工作簿都包含一个工作表 SearchCaseResults，所以我实质上需要执行的代码是循环通过打开英格兰工作簿的文件夹，选择工作表 SearchCaseResults，将该工作表上的数据从第2行复制到上次使用的行，然后粘贴到另一个工作簿中争议工作表的另一个文件夹中，然后选择下一个英格兰工作簿_2，选择此工作簿中的工作表 SearchCaseResults将工作表中的数据从第2行复制到上次使用的行，然后粘贴以下从争议工作表中的前一个工作表（英格兰）复制的数据，然后继续完成此复制和粘贴过程，直到文件夹中没有更多的工作簿。

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 BELOW the 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.

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

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.

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

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

代码

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

我应该指出，上面的代码是从

请参见图片2

PIC 1

PIC 2

推荐答案

尝试一下。我已经纠正了一些语法错误。目前还不清楚您是否只是从A列复制数据，但如果不是，则需要修改复制行。

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.

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

这篇关于将多个工作簿中的数据复制并粘贴到另一个工作簿中的工作表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！