excel如何快速把多个工作表合并到一个excel表

Sub CombineSheetsCells()
Dim wsNewWorksheet As Worksheet
Dim cel As Range
Dim DataSource, RowTitle, ColumnTitle, SourceDataRows, SourceDataColumns As Variant
Dim TitleRow, TitleColumn As Range
Dim Num As Integer
Dim DataRows As Long
DataRows=1
Dim TitleArr()
Dim Choice
Dim MyName$, MyFileName$, ActiveSheetName$, AddressAll$, AddressRow$, AddressColumn$, FileDir$, DataSheet$, myDelimiter$
Dim n, i
n=1
i=1
Application.DisplayAlerts=False
Worksheets("合并汇总表").Delete
Set wsNewWorksheet=Worksheets.Add(, after:=Worksheets(Worksheets.Count))
wsNewWorksheet.Name="合并汇总表"
MyFileName=Application.GetOpenFilename("Excel工作薄 (*.xls*),*.xls*")
If MyFileName="False" Then
MsgBox "没有选择文件！请重新选择一个被合并文件！", vbInformation, "取消"
Else
Workbooks.Open Filename:=MyFileName
Num=ActiveWorkbook.Sheets.Count
MyName=ActiveWorkbook.Name
Set DataSource=Application.InputBox(prompt:="请选择要合并的数据区域：", Type:=8)
AddressAll=DataSource.Address
ActiveWorkbook.ActiveSheet.Range(AddressAll).Select
SourceDataRows=Selection.Rows.Count
SourceDataColumns=Selection.Columns.Count
Application.ScreenUpdating=False
Application.EnableEvents=False
For i=1 To Num
ActiveWorkbook.Sheets(i).Activate
ActiveWorkbook.Sheets(i).Range(AddressAll).Select
Selection.Copy
ActiveSheetName=ActiveWorkbook.ActiveSheet.Name
Workbooks(ThisWorkbook.Name).Activate
ActiveWorkbook.Sheets("合并汇总表").Select
ActiveWorkbook.Sheets("合并汇总表").Range("A" & DataRows).Value=ActiveSheetName
ActiveWorkbook.Sheets("合并汇总表").Range(Cells(DataRows, 2), Cells(DataRows, 2)).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=_
False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
DataRows=DataRows + SourceDataRows
Workbooks(MyName).Activate
Next i
Application.ScreenUpdating=True
Application.EnableEvents=True
End If
Workbooks(MyName).Close
End Sub