Excel VBA_多工作簿多工作表汇总实例集锦(4)

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

百度搜索“77cn”或“免费范文网”即可找到本站免费阅读全部范文。收藏本站方便下次阅读，免费范文网，提供经典小说综合文库Excel VBA_多工作簿多工作表汇总实例集锦(4)在线全文阅读。