首页 文章

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

提问于
浏览 次
1

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

所以在PIC 1中你可以看到三个工作簿英格兰，England_2和England_3这些工作簿中的每一个都包含一个工作表"SearchCaseResults"所以我基本上需要代码做的是循环文件夹打开英格兰工作簿选择工作表"SearchCaseResults"从这个工作表上复制数据第2行到最后使用的行然后粘贴到另一个工作簿中的"Disputes"工作表，在另一个文件夹中，然后选择下一个工作簿England_2选择此工作簿中的工作表"SearchCaseResults"将此工作表上的数据从第2行复制到上次使用的行然后 PASTE IT BELOW 从"Disputes"工作表中的上一个工作表（英格兰）复制的数据，然后继续此复制和粘贴过程，直到文件夹中没有剩余的工作簿 .

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

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

码

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.

见图2

PIC 1

PIC 2

excel vba excel-vba copy-paste

1 回答

  • 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
    回复于

相关问题