宏：合并多个Excel文件，Excel合并Sheet

1、合并Excel文件
打开一个空Excel文件，Alt+F11，插入一个模块，开始写代码

Sub CombineWorkbooks()
Dim FilesToOpen, ft
Dim x As Integer
Application.ScreenUpdating = False
On Error GoTo errhandler
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Micrsofe Excel文件(*.xls), *.xls", _
MultiSelect:=True, Title:="要合并的文件")
If TypeName(FilesToOpen) = "boolean" Then
MsgBox "没有选定文件"
'GoTo errhandler
End If
x = 1
While x <= UBound(FilesToOpen)
Set wk = Workbooks.Open(Filename:=FilesToOpen(x))
wk.Sheets().Move after:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
x = x + 1
Wend
MsgBox "合并成功完成！"
errhandler:
'MsgBox Err.Description
'Resume errhandler
End Sub
这段代码的作用：它首先打开一个文件选择框，你可以选择一个或多个文件，
然后把这些文件里的所有Sheet合并到当前这个工作簿里来，有重名的Sheet会自动在后面加数字。

2、合并一个EXCEL多个sheet的内容到一个汇总sheet

Sub MergeWorkbooks()
Dim FileSet
Dim i As Integer

On Error GoTo 0
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

[c-sharp]view plaincopyprint?
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 0
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

'新建一个“汇总”工作表
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("汇总").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "汇总"

'开始复制的行号，忽略表头，无表头请设置成1
StartRow = 2

For Each sh In ActiveWorkbook.Worksheets

If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)

If shLast > 0 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 + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next

ExitSub:
Application.GoTo DestSh.Cells(1)
DestSh.Columns.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

这段代码的作用：它会新建一个叫做“汇总”的工作表，
然后把当前工作簿里的所有Sheet里有数据的内容都复制到“汇总”表里。
提示：如果数据表里的内容没有表头的话需要把StartRow = 2改成StartRow = 1。

实例：

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 0
End Function

Sub MergeSheets()
'
' Macro1 Macro
'
' 快捷键: Ctrl+t
'
Application.Goto Reference:="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

'新建一个“汇总”工作表
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("汇总").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "汇总"

'开始复制的行号，忽略表头，无表头请设置成1
StartRow = 5

For Each sh In ActiveWorkbook.Worksheets

If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)

If shLast > 0 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 + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next

ExitSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

转载于:https://www.cnblogs.com/pumkin/archive/2013/03/20/Pumkin.html