擁夢者? 原創(chuàng)? 于2016年12月20日23:30
前言
第2堤框、3集所說的多表匯總前兩種方法可以實(shí)現(xiàn)匯總效果朋蔫，不過效率應(yīng)該很低下找都，它的原理是打開每一個(gè)分表萝究，然后將分表中數(shù)據(jù)非空的單元格填充到總表對應(yīng)的單元格中免都，需要對每一個(gè)分表的每一個(gè)單元格進(jìn)行判斷，效率自然高不了帆竹。下面講一個(gè)效率高一些的方法绕娘，原理：打開各分表，將各分表數(shù)據(jù)復(fù)制粘貼到Excel表1中栽连，接下來刪除重復(fù)险领，再刪除數(shù)據(jù)為空的數(shù)據(jù)行，最后根據(jù)第一列排序得到最后結(jié)果秒紧。
注：演示基于Office2010版本绢陌，其它請自行參考。
下面是VBA代碼脐湾，請復(fù)制后粘貼到模塊中：
Sub 匯總各分表()
Dim Doc As Object, myDoc, a, d, i, str, N() ' 創(chuàng)建一些變量。
Application.ScreenUpdating = False? '關(guān)閉屏幕更新
Set Doc = CreateObject("Word.Application")? '新建Word對象
Doc.Visible = True? '可見
str = Dir(ThisWorkbook.Path & "\*.docx")? ? '在當(dāng)前路徑下搜索擴(kuò)展名為 docx 的文檔叙淌，這個(gè)地方可以根據(jù)自己需要替換
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 '關(guān)閉搜索到的文檔
str = Dir
Loop
Doc.Quit? ? '退出
'下面代碼是去重復(fù)數(shù)據(jù)
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
'下面是刪除數(shù)據(jù)為空的行
On Error GoTo myloop
Sheet1.UsedRange.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
ActiveWindow.SmallScroll Down:=42
Selection.EntireRow.Delete
'下面是恢復(fù)排序
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
保存文件后運(yùn)行等待結(jié)果……效果如下：
