【原創】如何將多個工作簿中相同格式的工作表合並到一個工作表中

如何將多個工作簿中相同格式的工作表合並到一個工作表中

Sub Books2Sheets()
     '定義對話框變量
      Application.ScreenUpdating = False
     Dim fd As FileDialog
     Set fd = Application.FileDialog(msoFileDialogFilePicker)
     
     '新建一個工作簿
     Dim newwb As Workbook
     Set newwb = Workbooks.Add
     
     With fd
         If .Show = -1 Then
             '定義單個文件變量
            Dim vrtSelectedItem As Variant
             
             '定義循環變量
            Dim i As Integer
             i = 1
             
             '開始文件檢索
            For Each vrtSelectedItem In .SelectedItems
                 '打開被合並工作簿
                Dim tempwb As Workbook
                 Set tempwb = Workbooks.Open(vrtSelectedItem)
                 
                 '復制工作表
                tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)
                 
                 '把新工作簿的工作表名字改成被復制工作簿文件名，這兒應用於xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsx
                 newwb.Worksheets(i).Name = VBA.Replace(tempwb.Name, ".xls", "")
                 
                 '關閉被合並工作簿
                tempwb.Close SaveChanges:=False
                 
                 i = i + 1
             Next vrtSelectedItem
         End If
     End With
     Set fd = Nothing
     Sheets("Sheet1").Select
     Sheets("Sheet1").Name = "匯總"
     MsgBox "現在已經過個工作簿中的sheet表合並到了一個工作簿中，現在開始將相同格式的工作表合並到一個sheet表中"
     Sheets("匯總").Select
     Call NsheetsTo1sheet
     Application.ScreenUpdating = True
 End Sub
 Sub NsheetsTo1sheet()
 Application.ScreenUpdating = False
 For j = 1 To Sheets.Count
 If Sheets(j).Name <> ActiveSheet.Name Then
 X = Range("A65536").End(xlUp).Row + 1
 Sheets(j).UsedRange.Copy Cells(X, 1)
 End If
 Next
 Range("B1").Select
 Application.ScreenUpdating = True
 MsgBox "當前工作簿下的全部工作表已經合並完畢！", vbInformation, "提示"
 End Sub