上一篇我们分享了用透视表分发EXCEL数据
在4S店还会遇到这样的情况：
为了数据整洁，将“集客记录”每天做一张表格，一个月一个EXCEL文件,里面有31张表，月底要要统计分析时需要汇总数据。
当然，其他行业也会遇到类似的情况：单个EXCEL文件中的多个表格合并成一个表格。
多表合并的前提条件：所有表格的表头完全一致
这在个前提下又分为两种情况：
一、表头位于第一行，所有数据向下累加
二、表头位于第一列，所有数据向右累加
另外，如果只想合并每张表的指定区域的数据怎么处理？
有些集团4S店，会将每个店的报表单独一页，各店的数据格式完全一致，如果只想分析其中某种业务的数据，就需要从每张表的指定区域复制数据出来。
下面给出的这个小工具，可以实现上述的功能。
这是向下合并的示例：
这是向右合并的示例：
向下合并截取部分数据的示例：
合并后，会自动将各个表的名字附在该表数据后面
这份源码如下：
Public multi As Boolean
Public selectrng As Variant
Function finalrow(sh As Worksheet)
Nrow = sh.UsedRange.Rows.Count
finalrow = sh.UsedRange.Rows(Nrow).Row
End Function
Function finalcol(sh As Worksheet)
Ncol = sh.UsedRange.Columns.Count
finalcol = sh.UsedRange.Columns(Ncol).Column
End Function
Sub CopyRangeFromMultiWorksheets()
Dim mybook As Workbook
Dim FName As Variant
Dim FNum As Long
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim CopyRng As Range
Dim frow As Long, fcol As Long
Dim Lrow As Long, Lcol As Long
Dim multirow As Boolean
FName = Application.GetOpenFilename(filefilter:=Excel Files (*.xl*), *.xl*, _
MultiSelect:=True)
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum), UpdateLinks:=0)
On Error GoTo 0
Next FNum
UserForm1.Show
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中带有数据的最后一行
Lrow = finalrow(DestSh)
Lcol = finalcol(DestSh)
frow = finalrow(sh)
fcol = finalcol(sh)
'设置希望复制的单元格区域
If selectrng = Then
Set CopyRng = sh.Range(sh.Cells(1, 1), sh.Cells(frow, fcol))
Else
Set CopyRng = sh.Range(selectrng)
End If
If multi Then
'测试工作表DestSh中是否有足够的行用来复制所有数据
If Lrow + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox 在工作表Destsh中没有足够的行用来放置数据!
GoTo ExitTheSub
End If
'下面的语句从每个工作表中复制值和格式
CopyRng.Copy
With DestSh.Cells(Lrow + 1, A)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'可选代码: 下面的语句复制工作表名称到最后一列
DestSh.Cells(Lrow + 1, fcol + 1).Resize(CopyRng.Rows.Count).Value = sh.Name
Else
If Lcol + CopyRng.Columns.Count DestSh.Columns.Count Then
MsgBox 在工作表Destsh中没有足够的列用来放置数据!
GoTo ExitTheSub
End If
'下面的语句从每个工作表中复制值和格式
CopyRng.Copy
With DestSh.Cells(1, Lcol + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'可选代码: 下面的语句复制工作表名称到最后一行
DestSh.Cells(frow + 1, Lcol + 1).Resize(1, CopyRng.Columns.Count).Value = sh.Name
End If
End If
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
'自动调整DestSh工作表的列宽
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
还有配合的窗体的源码：
Private Sub CommandButton1_Click()
'传递“向下”与“向右”的选择结果
If multi1.Value Then multi = True
If multi2.Value Then multi = False
'传递选区的输入结果
selectrng = selectbox.Value
'隐藏对话框
UserForm1.Hide
End Sub
如果需要源文件请关注微信公众号：EXCEL为工具4S店经营数据分析
留言索取
联系客服
