Excel 合并多个工作簿

Question

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 = "Select A Target Folder"
          .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)
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("T & A").Select                                  'Select the Sheet
        Range("D3").Select                                      'Set the Range
        Selection.Copy                                          'Change the Active File Name
        Windows("Dredger Summary Report.xlsm").Activate
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        'The next active cell will go to the offset
        ActiveCell.Offset(0, 1).Select
        'Next Instruction (Barge Volume)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("T & A").Select
        Range("F130").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 1).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Area)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("Input").Select
        Range("M12").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 1).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Material Type)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("Input").Select
        Range("AE12").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 1).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Depth Before)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("Input").Select
        Range("K12").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 1).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Depth After)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("Input").Select
        Range("J12").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 2).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Dredging Depth)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("Input").Select
        Range("I12").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 1).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Operational Hour)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("T & A").Select
        Range("F86").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 2).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Mechanical Maintenance)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("T & A").Select
        Range("F90").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(0, 1).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

        'Next Instruction (Shifting Anchor)
        '<<<<<<<<<<<<<Instruction Starts>>>>>>>>>>>>
        'Change the file that is open
        Windows(myFile).Activate
        Sheets("T & A").Select
        Range("F92").Select
        Selection.Copy
        Windows("Dredger Summary Report.xlsm").Activate

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveCell.Offset(1, -11).Select
        '<<<<<<<<<<<<<<Instruction Ends>>>>>>>>>>>>>

            'Save and Close Workbook
          wb.Close SaveChanges:=False
        '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

嗨，伙计们，所以我设法完善了我的脚本，从不同的工作簿中提取特定数据。但是我对经过多次询问和谷歌搜索后想出的代码有一个问题。

问题：如果您查看我的代码，每次我将活动工作簿(这是我的目标(名称更改为其他名称时，我都必须在此行Windows("Dredger Summary Report.xlsm"(下手动更改它。激活。无论如何，要编写一个代码，该代码将自动拾取活动工作簿和活动工作表，而无需每次更改文件名时都必须更改脚本中的名称？

谢谢并感谢任何意见

Answer 1

如注释中所述，ThisWorkbook表示运行宏的文件，因此您可以使用它。

同样，您已经将wb作为对循环中打开的每个工作簿的引用，因此您可以使用(例如(：

wb.Activate

代替

Windows(myFile).Activate

但是，应避免使用"激活/选择"，这样做的好处是使代码更具可读性/更精简。

而不是单个复制/粘贴：

    Windows(myFile).Activate
    Sheets("T & A").Select   
    Range("D3").Select       
    Selection.Copy           
    Windows("Dredger Summary Report.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                Operation:=xlNone, SkipBlanks:=False,Transpose:=False
    ActiveCell.Offset(0, 1).Select

你可以做类似的事情

    '...
    Dim rngDest As Range
    Set rngDest = Selection '<<starting point for your copying
    '...
    'then inside your loop...
    'copy#1
    wb.Sheets("T & A").Range("D3").Copy           
    rngDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                Operation:=xlNone, SkipBlanks:=False,Transpose:=False
    'copy#2 is offset one column over
    wb.Sheets("T & A").Range("F130").Copy
    rngDest.offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                Operation:=xlNone, SkipBlanks:=False,Transpose:=False
     'etc....