将多个工作簿中的多个工作表合并到一个具有相同工作表的工作簿中，但是将合并多个工作表中的数据

Question

我尝试在整个网络上查找此文件，但出于我的目的，到目前为止，我无法优化所需的代码。 这是我要完成的工作：

我有名为Excel 1，Excel 2，Excel 3和Master Excel的文件。 在标题等方面，所有文件都具有相同数量的工作表，工作表名称和相同的结构。

我正在尝试将Excel 1，Excel 2和Excel 3的值合并到Master文件中。

因此，在主文件上，如果有名为1000的工作表，则从Excel 1名为1000的工作表中复制粘贴一个范围。然后在Excel 2中查找工作表1000，并在主文件使用的最后一行之后的空白行上复制并粘贴一个范围文件工作表1000。

范围始终是标题之后的行（在所有工作表上都固定），直到最后一行包含特定列上的数据。

现在，每个工作簿中都有多个工作表，并且所有工作表将具有相同的名称。

文件的文件路径也将是恒定的，所以我不希望从中选择一个选项。

下面的代码能够遍历工作表，并且我也可以完美地定义复制粘贴范围，但是下面的唯一问题是我不知道如何将目标工作表与目标工作表匹配，这意味着工作表1000在excel 1文件中的数据粘贴到主文件中的工作表1000中。

Sub test()

Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long
'~~> Put additional variable declaration
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet

FilePath = "\\AM01PCIFS01.global.root\HomeDirs$\yameen.sarwar\Desktop\Test\II1\"
MyFiles = "\\AM01PCIFS01.global.root\HomeDirs$\yameen.sarwar\Desktop\Test\II1\*.xlsx"
MyFile = Dir(MyFiles)

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'~~> Set your declared variables
Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
Set wsMaster = wbMaster.Sheets("Sheet1") 'replace Sheet1 to suit

Do While Len(MyFile) > 0
    'Debug.Print MyFile
    If MyFile <> "master.xlsm" Then
        '~~> Open the file and at the same time, set your variable
        Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
        Set wsTemp = wbTemp.Sheets(1) 'I used index, you said there is only 1 sheet
        '~~> Now directly work on your object
        With wsMaster
            erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
            '~~> Copy from the file you opened
            wsTemp.Range("A2:S20").Copy 'you said this is fixed as well
            '~~> Paste on your master sheet
            .Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
        End With
        '~~> Close the opened file
        wbTemp.Close False 'set to false, because we opened it as read-only
        Set wsTemp = Nothing
        Set wbTemp = Nothing
    End If
    '~~> Load the new file
    MyFile = Dir
Loop

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Answer 1

要在wbMaster中获取工作表名称并在wbTemp中引用具有相同名称的工作表，可以通过变量传递名称。 这几行代码将循环遍历wbMaster中的工作表

Dim strSheetname as String

For i = 1 To wbMaster.Sheets.Count
      strSheetName = wbMaster.Sheets(i).Name
      Set wsTemp = wbTemp.Sheets(strSheetName)
      'Do whatever you need here with wsTemp
Next i

此代码缺少错误处理（即，如果wbMaster中存在工作表，而wbTemp中不存在工作表，则将出现超出范围的错误），但这将使您入门。

Answer 2

尝试此操作（请参阅代码中的注释），但是我在您的“ Do While”循环中做了一些小改动

Sub test()

Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long
'~~> Put additional variable declaration
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
Dim i As Integer

FilePath = "\\AM01PCIFS01.global.root\HomeDirs$\yameen.sarwar\Desktop\Test\II1\"
MyFiles = "\\AM01PCIFS01.global.root\HomeDirs$\yameen.sarwar\Desktop\Test\II1\*.xlsx"
MyFile = Dir(MyFiles)

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'~~> Set your declared variables
Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook

Do While Len(MyFile) > 0
    'Debug.Print MyFile
    If MyFile <> "master.xlsm" Then
        '~~> Open the file and at the same time, set your variable
        Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
        'Start the loop of sheets within the source workbook
        For i = 1 To wbTemp.Sheets.Count
            Set wsTemp = wbTemp.Sheets(i) 'I used index, you said there is only 1 sheet
            '~~> Now directly work on your object
            With wbMaster.Worksheets(wsTemp.Name) 'This matches the sheet name in the source workbook to the sheet name in the target workbook
                erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row of target sheet
                '~~> Copy from the file you opened
                wsTemp.Range("A2:S20").Copy 'you said this is fixed as well
                '~~> Paste on your master sheet
                .Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            End With
        Next i
        '~~> Close the opened file
        wbTemp.Close False 'set to false, because we opened it as read-only
    End If
    '~~> Load the new file
    MyFile = Dir
Loop

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub