同一EXCEL文件合并多个工作表数据到同一工作
表
首先，添加通用函数
1．打开VBE。
2．单击“插入——模块”，添加一个新模块。
3．在模块窗口，输入下面的代码。
Function LastRow(sh As Worksheet)
merge函数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
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _                            Lookat:=xlPart, _
LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column On Error GoTo 0
End Function
这两个函数分别用于查工作表中包含数据的最后一行和最后一列。
下面，我们将复制工作簿中所有工作表的数据，并将这些数据合并到一个汇总工作表中。
复制多个工作表中的所有数据
1． 在模块窗口输入下列代码后，运行即可。
Sub合并工作表()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.
EnableEvents = False
End With
'如果工作表"RDBMergeSheet"存在则将其删除
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete On Error GoTo 0
Application.DisplayAlerts = True
'添加一个名为"RDBMergeSheet"的工作表
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'遍历所有工作表并将数据复制到DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'到在工作表DestSh中带有数据的最后一行
Last = LastRow(DestSh)
'设置希望复制的单元格区域
Set CopyRng=sh.UsedRange
'测试工作表DestSh中是否有足够的行用来复制所有数据
If Last + CopyRng.Rows.Count >
DestSh.Rows.Count Then
MsgBox "在工作表Destsh中没有足够的行用来放置数据!"
GoTo ExitTheSub
End If
'下面的语句从每个工作表中复制值和格式
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'可选代码: 下面的语句复制工作表名称到H列
DestSh.Cells(Last + 1,
"H").Resize(CopyRng.Rows.Count).Value = sh.Name End If
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
'自动调整DestSh工作表的列宽
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。