【原创】如何将多个工作簿中相同格式的工作表合并到一个工作表中

如何将多个工作簿中相同格式的工作表合并到一个工作表中

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