合并多个工作簿

Sub Merge()
 Dim DestWB As Workbook
 Dim WB As Workbook
 Dim WS As Worksheet
 Dim SourceSheet As String
 Dim i As Long
 Dim n As Long
 Dim startRow As Long
 Dim lastRow As Long
 Dim FrtLoop As Boolean
 Dim FileNames As Variant
 Dim Fini As String
 Dim SheetName As String
 
 Set DestWB = ActiveWorkbook
 i = 1
 FrtLoop = True
 SourceSheet = "Sheet"
 startRow = 1
 Do
   FileNames = Application.GetOpenFilename( _
     filefilter:="Excel Files (*.xls*),*.xls*", _
     Title:="选择要合并的工作簿.", MultiSelect:=True)
   Fini = MsgBox("您是否选择了所有相关文件进行比较?", vbYesNoCancel)
 If Fini = vbYes Then
   GoTo CombineExit
   Exit Do
 ElseIf Fini = vbCancel Then
   Exit Sub
 ElseIf Fini = vbNo Then
   GoTo Combine
 End If
Continue:
 Loop While True = True
 Exit Sub
Combine:
 For n = LBound(FileNames) To UBound(FileNames)
   Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
   For Each WS In WB.Worksheets
     If WS.Name = SourceSheet Then
       With WS
         If .UsedRange.Cells.Count > 1 Then
           SheetName = "Data " & i
           DestWB.Sheets.Add.Name = SheetName
           lastRow = 1637
           If lastRow >= startRow Then
             .Range("A" & startRow & ":K" & lastRow).Copy DestWB.Worksheets(SheetName).Cells(1, "A")
           End If
           i = i + 1
         End If
       End With
       Exit For
     End If
   Next WS
   WB.Close savechanges:=False
 Next n
 GoTo Continue
CombineExit:
 For n = LBound(FileNames) To UBound(FileNames)
   Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
   For Each WS In WB.Worksheets
     If WS.Name = SourceSheet Then
       With WS
         If .UsedRange.Cells.Count > 1 Then
           SheetName = "Data " & i
           DestWB.Sheets.Add.Name = SheetName
           lastRow = 1637
           If lastRow >= startRow Then
            .Range("A" & startRow & ":K" & lastRow).Copy DestWB.Worksheets(SheetName).Cells(1, "A")
           End If
           i = i + 1
         End If
       End With
       Exit For
     End If
   Next WS
   WB.Close savechanges:=False
 Next n
End Sub