Excel VBA_多工作簿多工作表汇总实例集锦
1，多工作表汇总（Consolidate）
‘.excelpx./dispbbs.asp?boardID=5&ID=110630&page=1
‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。
Sub ConsolidateWorkbook()
Dim RangeArray() As String
Dim bk As Worksheet
Dim sht As Worksheet
Dim WbCount As Integer
Set bk = Sheets("汇总")
WbCount = Sheets.Count
ReDim RangeArray(1 To WbCount - 1)
For Each sht In Sheets
If https://www.360docs.net/doc/525362912.html, <> "汇总" Then
i = i + 1
RangeArray(i) = "'" & https://www.360docs.net/doc/525362912.html, & "'!" & _
sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
End If
Next
bk.Range("A1").Consolidate RangeArray, xlSum, True, True
[a1].Value = ""
End Sub
Sub sumdemo()
Dim arr As Variant
arr = Array("一月!R1C1:R8C5", "二月!R1C1:R5C4", "三月!R1C1:R9C6") With Worksheets("汇总").Range("A1")
.Consolidate arr, xlSum, True, True
.Value = ""
End With
End Sub
2，多工作簿汇总（Consolidate）
‘多工作簿汇总
Sub ConsolidateWorkbook()
Dim RangeArray() As String
Dim bk As Workbook
Dim sht As Worksheet
Dim WbCount As Integer
WbCount = Workbooks.Count
ReDim RangeArray(1 To WbCount - 1)
For Each bk In Workbooks '在所有工作簿中循环
If Not bk Is ThisWorkbook Then '非代码所在工作簿
Set sht = bk.Worksheets(1) '引用工作簿的第一个工作表
i = i + 1
RangeArray(i) = "'[" & https://www.360docs.net/doc/525362912.html, & "]" & https://www.360docs.net/doc/525362912.html, & "'!" & _ sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
End If
Next
Worksheets(1).Range("A1").Consolidate _
RangeArray, xlSum, True, True
End Sub
3，多工作簿汇总（FileSearch）
‘https://www.360docs.net/doc/525362912.html,/thread-442007-1-1.html###
‘help\汇总表.xls
Sub pldrwb0531()
'汇总表.xls
'导入指定文件的数据
Dim myFs As FileSearch
Dim myPath As String, Filename$
Dim i As Long, n As Long
Dim Sht1 As Worksheet, sh As Worksheet
Dim aa, nm$, nm1$, m, arr, r1, col1%
Application.ScreenUpdating = False
Set Sht1 = ActiveSheet
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName) > 0 Then
n = .FoundFiles.Count
col1 = 2
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 <> "汇总表" Then
Workbooks.Open myfile(i)
Dim wb As Workbook
Set wb = ActiveWorkbook
m = [a65536].End(xlUp).Row
arr = Range(Cells(3, 3), Cells(m, 3))
Sht1.Activate
col1 = col1 + 1
Cells(2, col1) = nm '自动获取文件名
Cells(3, col1).Resize(UBound(arr), 1) = arr
wb.Close savechanges:=False
Set wb = Nothing
End If
Next
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
[a1].Select
Set myFs = Nothing
Application.ScreenUpdating = True
End Sub
‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Public ar, ar1, nm$
Sub pldrwb0531()
'汇总表.xls
'导入指定文件的数据（默认工作表1的数据）
'直接从C列依次导入
Dim myFs As FileSearch
Dim myPath As String, Filename$
Dim i As Long, n As Long
Dim Sht1 As Worksheet, sh As Worksheet
Dim aa, nm1$, m, arr, r1, col1%
Application.ScreenUpdating = False
On Error Resume Next
Set Sht1 = ActiveSheet
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName) > 0 Then
n = .FoundFiles.Count
col1 = 2
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 <> "汇总表" Then
Workbooks.Open myfile(i)
Dim wb As Workbook
Set wb = ActiveWorkbook
For Each sh In Sheets
s = s & https://www.360docs.net/doc/525362912.html, & ","
Next
s = Left(s, Len(s) - 1)
ar = Split(s, ",")
UserForm1.Show
For j = 0 To UBound(ar1)
If Err.Number = 9 Then GoTo 100
Set sh = wb.Sheets(ar1(j))
sh.Activate
m = sh.[a65536].End(xlUp).Row
arr = Range(Cells(3, 3), Cells(m, 3))
Sht1.Activate
col1 = col1 + 1
Cells(2, col1) = sh.[a1]
Cells(3, col1).FormulaR1C1 = "=[" & nm & "]" & ar1(j) & "!RC3" ‘显示引用的工作簿工作表及单元格地址
Cells(3, col1).AutoFill Range(Cells(3, col1), Cells(UBound(arr) + 2, col1))
‘Cells(3, col1).Resize(UBound(arr), 1) = arr
Next j
100: wb.Close savechanges:=False
Set wb = Nothing
s = ""
If VarType(ar1) = 8200 Then Erase ar1
End If
Next
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
[a1].Select
Set myFs = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
s = s & ListBox1.List(i) & ","
End If
Next i
If s <> "" Then
s = Left(s, Len(s) - 1)
ar1 = Split(s, ",")
MsgBox "你选择了" & s
Unload UserForm1
Else
mg = MsgBox("你没有选择任何工作表！需要重新选择吗？", vbYesNo, "提示") If mg = 6 Then
Else
Unload UserForm1
End If
End If
End Sub
Private Sub CommandButton2_Click()
Unload UserForm1
End Sub
Private Sub UserForm_Initialize()
With Me.ListBox1
.List = ar ‘文本框赋值
.ListStyle = 1 ‘文本前加选择小方框
.MultiSelect = 1 ‘设置可多选
End With
https://www.360docs.net/doc/525362912.html,bel1.Caption = https://www.360docs.net/doc/525362912.html,bel1.Caption & nm
End Sub
4，多工作表汇总（字典、数组）
‘https://www.360docs.net/doc/525362912.html,/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D1
‘Data多表汇总0623.xls
Sub dbhz()
'多表汇总
Dim Sht1 As Worksheet, Sht2 As Worksheet, Sht As Worksheet
Dim d, k, t, Myr&, Arr, x
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
For Each Sht In Sheets ‘删除同名的表格，获得要增加的汇总表格不重复名字If InStr(https://www.360docs.net/doc/525362912.html,, "-") > 0 Then Sht.Delete: GoTo 100
nm = Mid(Sht.[a3], 7)
d(nm) = ""
100:
Next Sht
Application.DisplayAlerts = True
k = d.keys
For i = 0 To UBound(k)
Sheets.Add after:=Sheets(Sheets.Count)
Set Sht1 = ActiveSheet
https://www.360docs.net/doc/525362912.html, = Replace(k(i), "/", "-") ‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“
Next i
Erase k
Set d = Nothing
For Each Sht In Sheets
With Sht
.Activate
If InStr(.Name, "-") = 0 Then
nm = Replace(Mid(.[a3], 7), "/", "-")
Myr = .[h65536].End(xlUp).Row
Arr = .Range("d10:h" & Myr)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
x = Arr(i, 1)
If Not d.exists(x) Then
d.Add x, Arr(i, 5)
Else
d(x) = d(x) + Arr(i, 5)
End If
Next
k = d.keys
t = d.items
Set Sht2 = Sheets(nm)
Sht2.Activate
myr2 = [a65536].End(xlUp).Row + 1
If myr2 < 9 Then
Cells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")
Cells(10, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)
Cells(10, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) Else
Cells(myr2, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)
Cells(myr2, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t) End If
Erase k
Erase t
Set d = Nothing
End If
End With
Next Sht
Application.ScreenUpdating = True
End Sub
5，多工作簿提取指定数据（FileSearch）
‘2011-8-31
‘https://www.360docs.net/doc/525362912.html,/thread-759188-1-1.html
Sub GetData()
Dim Brrbz(1 To 200, 1 To 19), Brrgr(1 To 500, 1 To 23)
Dim myFs As FileSearch, myfile
Dim myPath As String, Filename$, wbnm$
Dim i&, n&, mm&, aa$, nm1$, j&
Dim Sht1 As Worksheet, sh As Worksheet, wb1 As Workbook
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
wbnm = Left(https://www.360docs.net/doc/525362912.html,, Len(https://www.360docs.net/doc/525362912.html,) - 4)
Set Sht1 = ActiveSheet
Sht1.[a2:w200] = ""
aa = Left(https://www.360docs.net/doc/525362912.html,, 2)
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path & "\"
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
.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)
nm1 = Split(Mid(Filename, InStrRev(Filename, "\") + 1), ".")(0)
If nm1 = wbnm Then GoTo 200
Workbooks.Open myfile(i)
Dim wb As Workbook
Set wb = ActiveWorkbook
For Each sh In Sheets
If InStr(https://www.360docs.net/doc/525362912.html,, aa) Then
sh.Activate
If aa = "班子" Then
mm = mm + 1
Brrbz(mm, 1) = [b2].Value
For j = 2 To 18 Step 2
If j < 10 Then
Brrbz(mm, j) = Cells(j / 2 + 34, 11).Value
Else
Brrbz(mm, j) = Cells(j / 2 + 34, 9).Value
End If
Next
GoTo 100
Else
If [b2] = "" Then GoTo 50
mm = mm + 1
Brrgr(mm, 1) = [b2].Value
Brrgr(mm, 2) = [e38].Value
Brrgr(mm, 3) = [i38].Value
For j = 4 To 18 Step 2
If j < 12 Then
Brrgr(mm, j) = Cells(j / 2 + 38, 8).Value
Else
Brrgr(mm, j) = Cells(j / 2 + 38, 7).Value
End If
Next
For j = 20 To 23
Brrgr(mm, j) = Cells(j + 28, 8).Value
Next
End If
End If
50:
Next
100:
wb.Close savechanges:=False
Set wb = Nothing
200:
Next
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
If aa = "班子" Then
[a2].Resize(mm, 19) = Brrbz
Else
[a2].Resize(mm, 23) = Brrgr
End If
[a1].Select
Set myFs = Nothing
End Sub
‘2011-7-15
‘https://www.360docs.net/doc/525362912.html,/viewthread.php?tid=741341&pid=5036524&page=1&extra= Sub pldrsj()
'批量导入指定文件的数据
Dim myFs As FileSearch, myfile, Brr
Dim myPath$, Filename$, nm2$
Dim i&, j&, n&, aa$, nm$
Dim Sht1 As Worksheet, sh As Worksheet
Application.ScreenUpdating = False
Set Sht1 = ActiveSheet
Sht1.Cells.ClearContents
nm2 = https://www.360docs.net/doc/525362912.html,
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName) > 0 Then
n = .FoundFiles.Count
ReDim Brr(1 To n, 1 To 2)
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) '带后缀的Excel文件名
If nm <> nm2 Then
j = j + 1
Workbooks.Open myfile(i)
Dim wb As Workbook
Set wb = ActiveWorkbook
Set sh = wb.Sheets("Sheet1")
Brr(j, 1) = nm
Brr(j, 2) = sh.[c3].Value
wb.Close savechanges:=False
Set wb = Nothing
End If
Next
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
Sht1.Select
[a3].Resize(UBound(Brr), 2) = Brr
Set myFs = Nothing
Application.ScreenUpdating = True
End Sub
Sub pldrsj0707()
'https://www.360docs.net/doc/525362912.html,/thread-456387-1-1.html
'Report 2.xls
'批量导入指定文件的数据
Dim myFs As FileSearch, myfile
Dim myPath As String, Filename$, ma&, mc&
Dim i As Long, n As Long, nn&, aa$, nm$, nm1$
Dim Sht1 As Worksheet, sh As Worksheet
Application.ScreenUpdating = False
Set Sht1 = ActiveSheet: nn = 5
Sht1.[b5:e27] = ""
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path & "\data" ‘指定的子文件夹内搜索
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
.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)
nm1=split(mid(filename,instrrev(filename,"\")+1),".")(0) 一句代码代替以下3句
‘aa = InStrRev(Filename, "\")
‘nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名
‘nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名
If nm1 <> https://www.360docs.net/doc/525362912.html, Then
Workbooks.Open myfile(i)
Dim wb As Workbook
Set wb = ActiveWorkbook
For Each sh In Sheets
sh.Activate
ma = [b65536].End(xlUp).Row
If ma > 6 Then ‘第6行是表头
If ma > 10 Then ma = 10 ‘只要取4行数据
For ii = 7 To ma
Sht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 2).Resize(1, 3).Value
Sht1.Cells(nn, 5) = Cells(ii, 6).Value
nn = nn + 1
Next ii
GoTo 100
Else
GoTo 100
End If
mc = [d65536].End(xlUp).Row
If mc > 7 Then ‘第7行是表头
If mc > 11 Then mc = 11 ‘只要取4行数据
For ii = 8 To mc
Sht1.Cells(nn, 2).Resize(1, 3) = Cells(ii, 4).Resize(1, 3).Value
Sht1.Cells(nn, 5) = Cells(ii, 8).Value
nn = nn + 1
Next ii
GoTo 100
Else
GoTo 100
End If
100:
Next sh
wb.Close savechanges:=False
Set wb = Nothing
End If
Next
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
[a1].Select
Set myFs = Nothing
Application.ScreenUpdating = True
End Sub
‘https://www.360docs.net/doc/525362912.html,/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D2
‘sum.xls
Sub pldrsj0724()
'批量导入指定文件的数据
Dim myFs As FileSearch, myfile, Myr1&, Arr
Dim myPath$, Filename$, nm2$
Dim i&, j&, n&, nn&, aa$, nm$, nm1$
Dim Sht1 As Worksheet, sh As Worksheet
Application.ScreenUpdating = False
Set Sht1 = ActiveSheet
Myr1 = Sht1.[a65536].End(xlUp).Row
Arr = Sht1.Range("a3:b" & Myr1)
Sht1.Range("b3:b" & Myr1).ClearContents
nm2 = Left(https://www.360docs.net/doc/525362912.html,, Len(https://www.360docs.net/doc/525362912.html,) - 4)
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
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) '带后缀的Excel文件名
nm1 = Left(nm, Len(nm) - 4) '去除后缀的Excel文件名
If nm1 <> nm2 Then
Workbooks.Open myfile(i)
Dim wb As Workbook
Set wb = ActiveWorkbook
For Each sh In Sheets
For j = 1 To UBound(Arr)
If https://www.360docs.net/doc/525362912.html, = Arr(j, 1) Then
sh.Activate
Set r1 = Range("c:c").Find(https://www.360docs.net/doc/525362912.html,)
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 https://www.360docs.net/doc/525362912.html, <> https://www.360docs.net/doc/525362912.html, Then
yf = Left(https://www.360docs.net/doc/525362912.html,, Len(https://www.360docs.net/doc/525362912.html,) - 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，多工作簿多工作表查询汇总去重复值（字典数组）
‘https://www.360docs.net/doc/525362912.html,/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 https://www.360docs.net/doc/525362912.html, = 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 https://www.360docs.net/doc/525362912.html, = 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）
‘https://www.360docs.net/doc/525362912.html,/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 = True
Application.ScreenUpdating = True
End Sub
9，多工作簿汇总（FileSearch+字典）
‘https://www.360docs.net/doc/525362912.html,/viewthread.php?tid=504957&pid=3323070&page=1& extra=page%3D1
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 = "*.xls"
.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 <> "合并" Then
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("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For j = 1 To UBound(Arr)
x = Year(Arr(j, 1)) & "年" & Month(Arr(j, 1)) & "月" & "|" & Arr(j, 2) & "|" & Arr(j, 3) & "|" & Arr(j, 5)
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）
‘https://www.360docs.net/doc/525362912.html,/viewthread.php?tid=511250&pid=3368549&page=1&extra=page%3D1 ‘年度汇总.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 & "*.xls")
Do While myName <> "" And myName <> funm
With GetObject(myPath & myName)
Arr = .Sheets("领料").Range("A1").CurrentRegion
For Each sh In wb.Sheets
shnm = https://www.360docs.net/doc/525362912.html,
sh.Activate
If InStr(shnm, "班") > 0 Then
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
‘https://www.360docs.net/doc/525362912.html,/viewthread.php?tid=629755&page=1#pid4261137
Sub tqsj()
Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet
Dim m&, funm$, shnm$, col%, i&, Myr&, Sht1 As Worksheet, pm$
Application.ScreenUpdating = False
On Error Resume Next