Question

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

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

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

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

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

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

见图2

PIC 1

PIC 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

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

1 个答案: