將多個工作簿中的多個工作表合並到一個具有相同工作表的工作簿中，但是將合並多個工作表中的數據

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