拥梦者 原创 于2016年12月20日23:30
前言
第2、3集所说的多表汇总前两种方法可以实现汇总效果，不过效率应该很低下，它的原理是打开每一个分表，然后将分表中数据非空的单元格填充到总表对应的单元格中，需要对每一个分表的每一个单元格进行判断，效率自然高不了。下面讲一个效率高一些的方法，原理：打开各分表，将各分表数据复制粘贴到Excel表1中，接下来删除重复，再删除数据为空的数据行，最后根据第一列排序得到最后结果。
注：演示基于Office2010版本，其它请自行参考。
下面是VBA代码，请复制后粘贴到模块中：
Sub 汇总各分表()
Dim Doc As Object, myDoc, a, d, i, str, N() ' 创建一些变量。
Application.ScreenUpdating = False '关闭屏幕更新
Set Doc = CreateObject("Word.Application") '新建Word对象
Doc.Visible = True '可见
str = Dir(ThisWorkbook.Path & "\*.docx") '在当前路径下搜索扩展名为 docx 的文档，这个地方可以根据自己需要替换
Do While Len(str) <> 0
i = i + 1
Set myDoc = Doc.Documents.Open(Chr(34) & ThisWorkbook.Path & "\" & str) '打开搜索到的文档
myDoc.Tables(1).Range.Copy
If Sheet1.Range("A50000").End(xlUp).Row = 1 Then
Sheet1.Range("A50000").End(xlUp).Select
Else
Sheet1.Range("A50000").End(xlUp).Offset(1, 0).Select
End If
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
myDoc.Close '关闭搜索到的文档
str = Dir
Loop
Doc.Quit '退出
'下面代码是去重复数据
ReDim N(0 To Sheet1.UsedRange.Columns.Count - 1)
For i = 1 To Sheet1.UsedRange.Columns.Count
N(i - 1) = i
Next
Sheet1.UsedRange.RemoveDuplicates N, xlNo
'下面是删除数据为空的行
On Error GoTo myloop
Sheet1.UsedRange.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
ActiveWindow.SmallScroll Down:=42
Selection.EntireRow.Delete
'下面是恢复排序
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Sheet1.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
myloop:
Application.ScreenUpdating = True '启用屏幕更新
End Sub
保存文件后运行等待结果……效果如下：
