拥梦者  原创  于2016年12月20日23:30

前言

第2、3集所说的多表汇总前两种方法可以实现汇总效果，不过效率应该很低下，它的原理是打开每一个分表，然后将分表中数据非空的单元格填充到总表对应的单元格中，需要对每一个分表的每一个单元格进行判断，效率自然高不了。下面讲一个效率高一些的方法，原理：打开各分表，将各分表数据复制粘贴到Excel表1中，接下来删除重复，再删除数据为空的数据行，最后根据第一列排序得到最后结果。

注：演示基于Office2010版本，其它请自行参考。

图1.新建总表.xlsm，其余步骤参考前面相关步骤 图2.VBA模块展示

下面是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

---

保存文件后运行等待结果……效果如下：

---

图3.最后汇总结果展示