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

Question

希望对你有所帮助。我目前有一段代码见下文。我希望它做的是允许用户访问 select 包含工作簿的文件夹。然后打开每个工作簿 select 一个名为 "SearchCaseResults" 的 sheet 从每个工作簿复制每个 "SearchCaseResults" 从第二行到最后使用的行的数据，并将此数据粘贴到名为 "Disputes" 的作品sheet 位于另一个文件夹的不同工作簿中。

所以在 PIC 1 中你可以看到三个工作簿 England，England_2 和 England_3 每个工作簿都包含一个作品sheet "SearchCaseResults" 所以我本质上需要的是要做的代码是循环打开 England workbook select worksheet "SearchCaseResults" 将这个 worksheet 的数据从第 2 行复制到最后使用的行，然后粘贴到"Disputes"工作sheet在另一个工作簿中，在另一个文件夹中，然后select下一个工作簿England_2select工作sheet"SearchCaseResults" 在本工作簿中，将本作品的数据sheet 从第 2 行复制到最后使用的行，然后将其粘贴到下面 从上一个作品中复制的数据sheet（英格兰) 在 "Disputes" Worksheet 中，然后继续此复制和粘贴过程，直到文件夹中没有更多的工作簿。

目前我的代码正在打开工作簿，这很好，selecting/activating 每个 "SearchCaseResults" 工作 sheet，但它只是处理单元格 A2 来自England sheets 然后它只是将最后一个 sheet 的数据粘贴到目标 Worksheet。（我怀疑之前的 sheets 的数据正在被粘贴over) 我的代码可以修改为将每个 "SearhCaseResults" sheet 中的数据从 A2 复制到最后使用的行，然后粘贴到 "Disputes" sheet 彼此下面。

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

代码

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

图片 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

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

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

excel

vba

copy-paste