Excel VBA_多工作簿多工作表汇总情况实例集锦(3)

If = Arr(j, 1) Then

sh.Activate

Set r1 = Range("c:c").Find()

nn = r1.Row

Arr(j, 2) = Cells(nn, 9)

GoTo 100

End If

Next j

Next sh

100:

wb.Close savechanges:=False

Set wb = Nothing

End If

Next

Else

MsgBox "该文件夹里没有任何文件"

End If

End With

Sht1.Select

[b3].Resize(UBound(Arr), 1) = Application.Index(Arr, 0, 2)

Set myFs = Nothing

Application.ScreenUpdating = True

End Sub

6，多工作表提取指定数据（数组）

‘excel.aa.topzj./viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718

Sub fpkf()

Application.ScreenUpdating = False

Dim Myr&, Arr, yf, x&, Myr1&, r1

Dim Sht As Worksheet

Myr = Sheet1.[b65536].End(xlUp).Row

Sheet1.Range("c8:h" & Myr).ClearContents

Arr = Sheet1.Range("c8:h" & Myr)

[j8].Formula = "=rc[-9]&""|""&rc[-8]"

[j8].AutoFill Range("j8:j" & Myr)

Range("j8:j" & Myr) = Range("j8:j" & Myr).Value

For Each Sht In Sheets

If <> Then

yf = Left(, Len() - 2)

Sht.Activate

Myr1 = [a65536].End(xlUp).Row - 1

For x = 7 To Myr1

If Cells(x, 1) <> "" Then

Set r1 = Sheet1.Range("j:j").Find(Cells(x, 1) & "|" & Cells(x, 2))

If Not r1 Is Nothing Then

Arr(r1.Row - 7, yf) = Cells(x, "ar")

End If

End If

Next x

End If

Next

Sheet1.Activate

[c8].Resize(UBound(Arr), UBound(Arr, 2)) = Arr

[j:j].Clear

Application.ScreenUpdating = True

End Sub

7，多工作簿多工作表查询汇总去重复值（字典数组）

‘/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D1‘详细记录.xls

‘3个工作簿需要都打开

Sub xxjl()

Dim Sht1 As Worksheet, Sht As Worksheet

Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook

Dim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$

Application.ScreenUpdating = False

Set wb1 = ActiveWorkbook

Set wb2 = Workbooks("购进")

Set wb3 = Workbooks("配料")

wb2.Activate

Myr2 = [a65536].End(xlUp).Row

Arr2 = Range("a2:d" & Myr2)

wb3.Activate

For i = 1 To UBound(Arr2)

wb3.Activate

xm = Arr2(i, 2)

For Each Sht In Sheets

If = xm Then

Sht.Activate

Myr = [a65536].End(xlUp).Row

Arr = Range("a1:b" & Myr)

For j = 1 To UBound(Arr)

yl = Arr(j, 1)

wb1.Activate

For Each Sht1 In Sheets

If = yl Then

Sht1.Activate

Myr1 = [a65536].End(xlUp).Row + 1

Cells(Myr1, 1) = Arr2(i, 1)

Cells(Myr1, 3) = Arr2(i, 3)

Cells(Myr1, 2) = Arr2(i, 4) * Arr(j, 2) Exit For

End If

Next

Next j

GoTo 100

End If

Next

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("a2:c" & Myr)

Set d = CreateObject("Scripting.Dictionary")

If Myr < 3 Then GoTo 100

For i = 1 To UBound(Arr)

x = Arr(i, 1) & "," & Arr(i, 3)

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), ",")(0)

Arr1(j + 1, 3) = Split(k(j), ",")(1)

Arr1(j + 1, 2) = t(j)

Next j

Range("a2:c" & Myr).ClearContents

[a2].Resize(UBound(Arr1), 3) = Arr1

100:

Set d = Nothing

Next

Application.ScreenUpdating = True

End Sub

8，多工作簿对比（FileSearch）

‘/viewthread.php?tid=499599&pid=3285214&page=1&extra=page%3D1 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], "费用明细表") > 0 Then

nm = Left(Sht1.[a1], Len(Sht1.[a1]) - 5)

Sht1.Activate

With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem

.Filename = nm & ".xls"

.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), ".")(1))

Sht1.Activate

For j = 1 To UBound(arr)

Set r1 = Sht1.Range("c:c").Find(arr(j, 3))

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 …… 此处隐藏：3728字，全部文档内容请下载后查看。喜欢就下载吧 ……