100: Next i Call qccf
Application.ScreenUpdating = True End Sub Sub qccf()
Dim Sht As Worksheet, Myr&, Arr, i&, x Dim d, k, t, Arr1, j&
Application.ScreenUpdating = False For Each Sht In Sheets Sht.Activate
Myr = [a65536].End(xlUp).Row Arr = Range(\
Set d = CreateObject(\ If Myr < 3 Then GoTo 100 For i = 1 To UBound(Arr)
x = Arr(i, 1) & \ If Not d.exists(x) Then d(x) = Arr(i, 2) Else
d(x) = d(x) + Arr(i, 2) End If Next
k = d.keys t = d.items
ReDim Arr1(1 To UBound(k) + 1, 1 To 3) For j = 0 To UBound(k)
Arr1(j + 1, 1) = Split(k(j), \ Arr1(j + 1, 3) = Split(k(j), \ Arr1(j + 1, 2) = t(j) Next j
Range(\ [a2].Resize(UBound(Arr1), 3) = Arr1 100:
Set d = Nothing Next
Application.ScreenUpdating = True End Sub
8，多工作簿对比（FileSearch）
‘http://club.excelhome.net/viewthread.php?tid=499599&pid=3285214&page=1&extra=page=
1
Sub dgzbdb()
'多工作簿对比
'by:蓝桥 2009-11-7
Dim myFs As FileSearch
Dim myPath As String, Filename$ Dim i&, n&, nm$, myfile
Dim Sht1 As Worksheet, sh As Worksheet Dim wb1 As Workbook, yf, j&, m1& Dim m, arr, r1
Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Set wb1 = ThisWorkbook
Set myFs = Application.FileSearch myPath = ThisWorkbook.Path For Each Sht1 In Sheets
If InStr(Sht1.[a1], \费用明细表\
nm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5) Sht1.Activate With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem .Filename = nm & \ .SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName) > 0 Then myfile = .FoundFiles(1) Workbooks.Open myfile Dim wb As Workbook
Set wb = ActiveWorkbook Set sh = wb.ActiveSheet
m = sh.[a65536].End(xlUp).Row
arr = sh.Range(Cells(2, 1), Cells(m, 6)) yf = Val(Split(arr(2, 1), \ Sht1.Activate
For j = 1 To UBound(arr)
Set r1 = Sht1.Range(\ If r1 Is Nothing Then
m1 = Sht1.[d65536].End(xlUp).Row
Cells(m1, 1).EntireRow.Insert shift:=xlUp Cells(m1, 1) = Cells(m1 - 1, 1) + 1 Cells(m1, 2) = arr(j, 3)
Cells(m1, yf + 3) = arr(j, 6)
End If Next j
wb.Close savechanges:=False Set wb = Nothing End If End With End If Next
Set myFs = Nothing
Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
9，多工作簿汇总（FileSearch+字典）
‘http://club.excelhome.net/viewthread.php?tid=504957&pid=3323070&page=1&extra=page=1
Sub pldrwb1123() '合并.xls
'导入指定文件的数据
Dim myFs As FileSearch
Dim myPath As String, Filename$ Dim i&, n&, y&, bb, j&, x
Dim Sht1 As Worksheet, sh As Worksheet Dim aa, nm$, nm1$, m, Arr, r1, mm& Dim d, k, t, d1, t1
Application.ScreenUpdating = False mm = 8
Set Sht1 = ActiveSheet
Sht1.[a8:h1000].ClearContents Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem .Filename = \
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count
ReDim myfile(1 To n) As String For i = 1 To n
myfile(i) = .FoundFiles(i)
Filename = myfile(i)
aa = InStrRev(Filename, \
nm = Right(Filename, Len(Filename) - aa) nm1 = Left(nm, Len(nm) - 4) If nm1 <> \合并\
Workbooks.Open myfile(i) Dim wb As Workbook Set wb = ActiveWorkbook m = [a65536].End(xlUp).Row
Arr = Range(Cells(8, 1), Cells(m, 7))
Set d = CreateObject(\ Set d1 = CreateObject(\ For j = 1 To UBound(Arr)
x = Year(Arr(j, 1)) & \年\月\2) & \
d(x) = d(x) + Arr(j, 4) d1(x) = Arr(j, 7) Next
k = d.keys t = d.items t1 = d1.items Sht1.Activate
For y = 0 To UBound(k) bb = Split(k(y), \ Cells(mm, 1) = nm1 Cells(mm, 2) = bb(0) Cells(mm, 3) = bb(1) Cells(mm, 4) = bb(2) Cells(mm, 5) = t(y) Cells(mm, 6) = bb(3)
Cells(mm, 7) = t(y) * bb(3) Cells(mm, 8) = t1(y) mm = mm + 1 Next
wb.Close savechanges:=False Set wb = Nothing Set d = Nothing Set d1 = Nothing End If Next Else
MsgBox \该文件夹里没有任何文件\ End If End With
[a1].Select
Set myFs = Nothing
Application.ScreenUpdating = True End Sub
10，多工作簿多工作表提取数据（Do While）
‘http://club.excelhome.net/viewthread.php?tid=511250&pid=3368549&page=1&extra=page=1
‘年度汇总.xls Sub ndhz()
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet Dim m&, funm$, shnm$, col%, i& Application.ScreenUpdating = False Set wb = ThisWorkbook funm = \年度汇总.xls\
myPath = ThisWorkbook.Path & \ myName = Dir(myPath & \
Do While myName <> \ With GetObject(myPath & myName)
Arr = .Sheets(\领料\ For Each sh In wb.Sheets shnm = sh.Name sh.Activate
If InStr(shnm, \班\ col = 11 Else
col = 7 End If
For i = 2 To UBound(Arr) If Arr(i, col) = shnm Then
m = sh.[a65536].End(xlUp).Row + 1
Cells(m, 1).Resize(1, 12) = Application.Index(Arr, i, 0) End If Next Next
.Close False End With
myName = Dir Loop
Application.ScreenUpdating = True End Sub