标签：VBA
很多时候，我们都有将多个工作簿合并成一个工作簿的需求。当然，根据需求的不同，合并工作簿的代码会有差异。在完美Excel中给出过多个合并工作簿的示例，有兴趣的朋友可以查阅历史文章。
本文的示例是另一种情况：合并多个工作簿中指定名称的工作表，即将多个工作簿指定名称的工作表复制到当前工作簿中并重命名。这段代码收集自网络，辑录于此。
代码如下，有兴趣的朋友可以自行研究：
代码语言：javascript复制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
