1、合并多个Excel工作簿
Sub MergeWorkbooks()
Dim FileSet
Dim i As Integer On Error GoTo
Application.ScreenUpdating = False FileSet = Application.GetOpenFilename(FileFilter:="Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx", _
MultiSelect:=True, Title:="选择要合并的文件") If TypeName(FileSet) = "Boolean" Then
GoTo ExitSub
End If For Each Filename In FileSet
Workbooks.Open Filename
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next ExitSub:
Application.ScreenUpdating = True End Sub
2、合并一个工作簿下多个一致性SHEET
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo
End Function Sub MergeSheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long Application.ScreenUpdating = False
Application.EnableEvents = False '新建“汇总”Sheet
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("汇总").Delete
On Error GoTo
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "汇总" '开始复制的行号，无表头设置为1
StartRow = For Each sh In ActiveWorkbook.Worksheets If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh) If shLast > And shLast >= StartRow Then Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "超过最大容量！"
GoTo ExitSub
End If CopyRng.Copy
With DestSh.Cells(Last + , "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next ExitSub:
Application.GoTo DestSh.Cells()
DestSh.Columns.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True End Sub