1，多工作表汇总（Consolidate）
‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=110630&page=1
‘两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。
SubConsolidateWorkbook()
DimRangeArray()AsString
DimbkAsWorksheet
DimshtAsWorksheet
DimWbCountAsInteger
Setbk=Sheets("汇总")
WbCount=Sheets.Count
ReDimRangeArray(1ToWbCount-1)
ForEachshtInSheets
Ifsht.Name<>"汇总"Then
i=i+1
RangeArray(i)="''"&sht.Name&"''!"&_
sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
EndIf
Next
bk.Range("A1").ConsolidateRangeArray,xlSum,True,True
[a1].Value="姓名"
EndSub
Subsumdemo()
DimarrAsVariant
arr=Array("一月!R1C1:R8C5","二月!R1C1:R5C4","三月!R1C1:R9C6")
WithWorksheets("汇总").Range("A1")
.Consolidatearr,xlSum,True,True
.Value="姓名"
EndWith
EndSub
2，多工作簿汇总（Consolidate）
‘多工作簿汇总
SubConsolidateWorkbook()
DimRangeArray()AsString
DimbkAsWorkbook
DimshtAsWorksheet
DimWbCountAsInteger
WbCount=Workbooks.Count
ReDimRangeArray(1ToWbCount-1)
ForEachbkInWorkbooks''在所有工作簿中循环
IfNotbkIsThisWorkbookThen''非代码所在工作簿
Setsht=bk.Worksheets(1)''引用工作簿的第一个工作表
i=i+1
RangeArray(i)="''["&bk.Name&"]"&sht.Name&"''!"&_
sht.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
EndIf
Next
Worksheets(1).Range("A1").Consolidate_
RangeArray,xlSum,True,True
EndSub
3，多工作簿汇总（FileSearch）
‘http://club.excelhome.net/thread-442007-1-1.html###
‘help\汇总表.xls
Subpldrwb0531()
''汇总表.xls
''导入指定文件的数据
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
DimiAsLong,nAsLong
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm$,nm1$,m,arr,r1,col1%
Application.ScreenUpdating=False
SetSht1=ActiveSheet
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
col1=2
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
aa=InStrRev(Filename,"\")
nm=Right(Filename,Len(Filename)-aa)
nm1=Left(nm,Len(nm)-4)
Ifnm1<>"汇总表"Then
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=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.Closesavechanges:=False
Setwb=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
EndSub
‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能
Publicar,ar1,nm$
Subpldrwb0531()
''汇总表.xls
''导入指定文件的数据（默认工作表1的数据）
''直接从C列依次导入
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
DimiAsLong,nAsLong
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm1$,m,arr,r1,col1%
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
col1=2
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
aa=InStrRev(Filename,"\")
nm=Right(Filename,Len(Filename)-aa)
nm1=Left(nm,Len(nm)-4)
Ifnm1<>"汇总表"Then
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
s=s&sh.Name&","
Next
s=Left(s,Len(s)-1)
ar=Split(s,",")
UserForm1.Show
Forj=0ToUBound(ar1)
IfErr.Number=9ThenGoTo100
Setsh=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).AutoFillRange(Cells(3,col1),Cells(UBound(arr)+2,col1))
‘Cells(3,col1).Resize(UBound(arr),1)=arr
Nextj
100:wb.Closesavechanges:=False
Setwb=Nothing
s=""
IfVarType(ar1)=8200ThenErasear1
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
EndSub
PrivateSubCommandButton1_Click()
Fori=0ToListBox1.ListCount-1
IfListBox1.Selected(i)=TrueThen
s=s&ListBox1.List(i)&","
EndIf
Nexti
Ifs<>""Then
s=Left(s,Len(s)-1)
ar1=Split(s,",")
MsgBox"你选择了"&s
UnloadUserForm1
Else
mg=MsgBox("你没有选择任何工作表！需要重新选择吗？",vbYesNo,"提示")
Ifmg=6Then
Else
UnloadUserForm1
EndIf
EndIf
EndSub
PrivateSubCommandButton2_Click()
UnloadUserForm1
EndSub
PrivateSubUserForm_Initialize()
WithMe.ListBox1
.List=ar‘文本框赋值
.ListStyle=1‘文本前加选择小方框
.MultiSelect=1‘设置可多选
EndWith
Me.Label1.Caption=Me.Label1.Caption&nm
EndSub
4，多工作表汇总（字典、数组）
‘http://club.excelhome.net/viewthread.php?tid=450709&pid=2928374&page=1&extra=page%3D1
‘Data多表汇总0623.xls
Subdbhz()
''多表汇总
DimSht1AsWorksheet,Sht2AsWorksheet,ShtAsWorksheet
Dimd,k,t,Myr&,Arr,x
Application.ScreenUpdating=False
Application.DisplayAlerts=False
Setd=CreateObject("Scripting.Dictionary")
ForEachShtInSheets‘删除同名的表格，获得要增加的汇总表格不重复名字
IfInStr(Sht.Name,"-")>0ThenSht.Delete:GoTo100
nm=Mid(Sht.[a3],7)
d(nm)=""
100:
NextSht
Application.DisplayAlerts=True
k=d.keys
Fori=0ToUBound(k)
Sheets.Addafter:=Sheets(Sheets.Count)
SetSht1=ActiveSheet
Sht1.Name=Replace(k(i),"/","-")‘增加汇总表，把名字中的”/”（不能用作表名的）改为”-“
Nexti
Erasek
Setd=Nothing
ForEachShtInSheets
WithSht
.Activate
IfInStr(.Name,"-")=0Then
nm=Replace(Mid(.[a3],7),"/","-")
Myr=.[h65536].End(xlUp).Row
Arr=.Range("d10:h"&Myr)
Setd=CreateObject("Scripting.Dictionary")
Fori=1ToUBound(Arr)
x=Arr(i,1)
IfNotd.exists(x)Then
d.Addx,Arr(i,5)
Else
d(x)=d(x)+Arr(i,5)
EndIf
Next
k=d.keys
t=d.items
SetSht2=Sheets(nm)
Sht2.Activate
myr2=[a65536].End(xlUp).Row+1
Ifmyr2<9Then
Cells(9,1).Resize(1,2)=Array("PartNo.","TTLQty")
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)
EndIf
Erasek
Eraset
Setd=Nothing
EndIf
EndWith
NextSht
Application.ScreenUpdating=True
EndSub
5，多工作簿提取指定数据（FileSearch）
‘2011-8-31
‘http://club.excelhome.net/thread-759188-1-1.html
SubGetData()
DimBrrbz(1To200,1To19),Brrgr(1To500,1To23)
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,wbnm$
Dimi&,n&,mm&,aa$,nm1$,j&
DimSht1AsWorksheet,shAsWorksheet,wb1AsWorkbook
Application.ScreenUpdating=False
Setwb1=ThisWorkbook
wbnm=Left(wb1.Name,Len(wb1.Name)-4)
SetSht1=ActiveSheet
Sht1.[a2:w200]=""
aa=Left(Sht1.Name,2)
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path&"\"
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
.SearchSubFolders=True
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
Ifnm1=wbnmThenGoTo200
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
IfInStr(sh.Name,aa)Then
sh.Activate
Ifaa="班子"Then
mm=mm+1
Brrbz(mm,1)=[b2].Value
Forj=2To18Step2
Ifj<10Then
Brrbz(mm,j)=Cells(j/2+34,11).Value
Else
Brrbz(mm,j)=Cells(j/2+34,9).Value
EndIf
Next
GoTo100
Else
If[b2]=""ThenGoTo50
mm=mm+1
Brrgr(mm,1)=[b2].Value
Brrgr(mm,2)=[e38].Value
Brrgr(mm,3)=[i38].Value
Forj=4To18Step2
Ifj<12Then
Brrgr(mm,j)=Cells(j/2+38,8).Value
Else
Brrgr(mm,j)=Cells(j/2+38,7).Value
EndIf
Next
Forj=20To23
Brrgr(mm,j)=Cells(j+28,8).Value
Next
EndIf
EndIf
50:
Next
100:
wb.Closesavechanges:=False
Setwb=Nothing
200:
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
Ifaa="班子"Then
[a2].Resize(mm,19)=Brrbz
Else
[a2].Resize(mm,23)=Brrgr
EndIf
[a1].Select
SetmyFs=Nothing
EndSub
‘2011-7-15
‘http://club.excelhome.net/viewthread.php?tid=741341&pid=5036524&page=1&extra=
Subpldrsj()''批量导入指定文件的数据??DimmyFsAsFileSearch,myfile,Brr??DimmyPath$,Filename$,nm2$??Dimi&,j&,n&,aa$,nm$??DimSht1AsWorksheet,shAsWorksheet??Application.ScreenUpdating=False??SetSht1=ActiveSheet??Sht1.Cells.ClearContents??nm2=ActiveWorkbook.Name??SetmyFs=Application.FileSearch??myPath=ThisWorkbook.Path??WithmyFs??????.NewSearch??????.LookIn=myPath??????.FileType=msoFileTypeNoteItem??????.Filename=".xls"??????.SearchSubFolders=True??????If.Execute(SortBy:=msoSortByFileName)>0Then????????n=.FoundFiles.Count????????ReDimBrr(1Ton,1To2)????????ReDimmyfile(1Ton)AsString????????Fori=1Ton??????????myfile(i)=.FoundFiles(i)??????????Filename=myfile(i)??????????aa=InStrRev(Filename,"\")??????????nm=Right(Filename,Len(Filename)-aa)????''带后缀的Excel文件名??????????Ifnm<>nm2Then??????????????j=j+1??????????????Workbooks.Openmyfile(i)??????????????DimwbAsWorkbook??????????????Setwb=ActiveWorkbook??????????????Setsh=wb.Sheets("Sheet1")??????????????Brr(j,1)=nm??????????????Brr(j,2)=sh.[c3].Value??????????????wb.Closesavechanges:=False??????????????Setwb=Nothing??????????EndIf????????Next??????Else????????MsgBox"该文件夹里没有任何文件"??????EndIf??EndWith??Sht1.Select??[a3].Resize(UBound(Brr),2)=Brr??SetmyFs=NothingApplication.ScreenUpdating=TrueEndSub
Subpldrsj0707()
''http://club.excelhome.net/thread-456387-1-1.html
''Report2.xls
''批量导入指定文件的数据
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,ma&,mc&
DimiAsLong,nAsLong,nn&,aa$,nm$,nm1$
DimSht1AsWorksheet,shAsWorksheet
Application.ScreenUpdating=False
SetSht1=ActiveSheet:nn=5
Sht1.[b5:e27]=""
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path&"\data"‘指定的子文件夹内搜索
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
.SearchSubFolders=True
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
ReDimmyfile(1Ton)AsString
Fori=1Ton
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文件名
Ifnm1<>Sht1.NameThen
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
sh.Activate
ma=[b65536].End(xlUp).Row
Ifma>6Then‘第6行是表头
Ifma>10Thenma=10‘只要取4行数据
Forii=7Toma
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
Nextii
GoTo100
Else
GoTo100
EndIf
mc=[d65536].End(xlUp).Row
Ifmc>7Then‘第7行是表头
Ifmc>11Thenmc=11‘只要取4行数据
Forii=8Tomc
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
Nextii
GoTo100
Else
GoTo100
EndIf
100:
Nextsh
wb.Closesavechanges:=False
Setwb=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/viewthread.php?tid=462710&pid=3020658&page=1&extra=page%3D2
‘sum.xls
Subpldrsj0724()
''批量导入指定文件的数据
DimmyFsAsFileSearch,myfile,Myr1&,Arr
DimmyPath$,Filename$,nm2$
Dimi&,j&,n&,nn&,aa$,nm$,nm1$
DimSht1AsWorksheet,shAsWorksheet
Application.ScreenUpdating=False
SetSht1=ActiveSheet
Myr1=Sht1.[a65536].End(xlUp).Row
Arr=Sht1.Range("a3:b"&Myr1)
Sht1.Range("b3:b"&Myr1).ClearContents
nm2=Left(ActiveWorkbook.Name,Len(ActiveWorkbook.Name)-4)
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
aa=InStrRev(Filename,"\")
nm=Right(Filename,Len(Filename)-aa)''带后缀的Excel文件名
nm1=Left(nm,Len(nm)-4)''去除后缀的Excel文件名
Ifnm1<>nm2Then
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInSheets
Forj=1ToUBound(Arr)
Ifsh.Name=Arr(j,1)Then
sh.Activate
Setr1=Range("c:c").Find(sh.Name)
nn=r1.Row
Arr(j,2)=Cells(nn,9)
GoTo100
EndIf
Nextj
Nextsh
100:
wb.Closesavechanges:=False
Setwb=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
Sht1.Select
[b3].Resize(UBound(Arr),1)=Application.Index(Arr,0,2)
SetmyFs=Nothing
Application.ScreenUpdating=True
EndSub
6，多工作表提取指定数据（数组）
‘http://excel.aa.topzj.com/viewthread.php?tid=399457&pid=73718&page=1&extra=#pid73718
Subfpkf()
Application.ScreenUpdating=False
DimMyr&,Arr,yf,x&,Myr1&,r1
DimShtAsWorksheet
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].AutoFillRange("j8:j"&Myr)
Range("j8:j"&Myr)=Range("j8:j"&Myr).Value
ForEachShtInSheets
IfSht.Name<>Sheet1.NameThen
yf=Left(Sht.Name,Len(Sht.Name)-2)
Sht.Activate
Myr1=[a65536].End(xlUp).Row-1
Forx=7ToMyr1
IfCells(x,1)<>""Then
Setr1=Sheet1.Range("j:j").Find(Cells(x,1)&"|"&Cells(x,2))
IfNotr1IsNothingThen
Arr(r1.Row-7,yf)=Cells(x,"ar")
EndIf
EndIf
Nextx
EndIf
Next
Sheet1.Activate
[c8].Resize(UBound(Arr),UBound(Arr,2))=Arr
[j:j].Clear
Application.ScreenUpdating=True
EndSub
7，多工作簿多工作表查询汇总去重复值（字典数组）
‘http://club.excelhome.net/viewthread.php?tid=485193&pid=3181286&page=1&extra=page%3D1
‘详细记录.xls
‘3个工作簿需要都打开
Subxxjl()DimSht1AsWorksheet,ShtAsWorksheetDimwb1AsWorkbook,wb2AsWorkbook,wb3AsWorkbookDimi&,Myr2&,Arr2,Myr&,Arr,Myr1&,xm$,yl$Application.ScreenUpdating=FalseSetwb1=ActiveWorkbookSetwb2=Workbooks("购进")Setwb3=Workbooks("配料")wb2.ActivateMyr2=[a65536].End(xlUp).RowArr2=Range("a2:d"&Myr2)wb3.ActivateFori=1ToUBound(Arr2)??wb3.Activate??xm=Arr2(i,2)??ForEachShtInSheets??????IfSht.Name=xmThen????????Sht.Activate????????Myr=[a65536].End(xlUp).Row????????Arr=Range("a1:b"&Myr)????????Forj=1ToUBound(Arr)??????????yl=Arr(j,1)??????????wb1.Activate??????????ForEachSht1InSheets??????????????IfSht1.Name=ylThen????????????????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)????????????????ExitFor??????????????EndIf??????????Next????????Nextj????????GoTo100??????EndIf??Next100:NextiCallqccfApplication.ScreenUpdating=TrueEndSubSubqccf()DimShtAsWorksheet,Myr&,Arr,i&,xDimd,k,t,Arr1,j&Application.ScreenUpdating=FalseForEachShtInSheets??Sht.Activate??Myr=[a65536].End(xlUp).Row??Arr=Range("a2:c"&Myr)??Setd=CreateObject("Scripting.Dictionary")??IfMyr<3ThenGoTo100??Fori=1ToUBound(Arr)??????x=Arr(i,1)&","&Arr(i,3)??????IfNotd.exists(x)Then????????d(x)=Arr(i,2)??????Else????????d(x)=d(x)+Arr(i,2)??????EndIf??Next??k=d.keys??t=d.items??ReDimArr1(1ToUBound(k)+1,1To3)??Forj=0ToUBound(k)??????Arr1(j+1,1)=Split(k(j),",")(0)??????Arr1(j+1,3)=Split(k(j),",")(1)??????Arr1(j+1,2)=t(j)??Nextj??Range("a2:c"&Myr).ClearContents??[a2].Resize(UBound(Arr1),3)=Arr1100:??Setd=NothingNextApplication.ScreenUpdating=TrueEndSub
8，多工作簿对比（FileSearch）
‘http://club.excelhome.net/viewthread.php?tid=499599&pid=3285214&page=1&extra=page%3D1
Subdgzbdb()''多工作簿对比''by:蓝桥DimmyFsAsFileSearchDimmyPathAsString,Filename$Dimi&,n&,nm$,myfileDimSht1AsWorksheet,shAsWorksheetDimwb1AsWorkbook,yf,j&,m1&Dimm,arr,r1Application.ScreenUpdating=FalseApplication.DisplayAlerts=FalseOnErrorResumeNextSetwb1=ThisWorkbookSetmyFs=Application.FileSearchmyPath=ThisWorkbook.PathForEachSht1InSheets??IfInStr(Sht1.[a1],"费用明细表")>0Then??????nm=Left(Sht1.[a1],Len(Sht1.[a1])-5)??????Sht1.Activate??????WithmyFs????????.NewSearch????????.LookIn=myPath????????.FileType=msoFileTypeNoteItem????????.Filename=nm&".xls"????????.SearchSubFolders=True????????If.Execute(SortBy:=msoSortByFileName)>0Then??????????myfile=.FoundFiles(1)??????????Workbooks.Openmyfile??????????DimwbAsWorkbook??????????Setwb=ActiveWorkbook??????????Setsh=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??????????Forj=1ToUBound(arr)??????????????Setr1=Sht1.Range("c:c").Find(arr(j,3))??????????????Ifr1IsNothingThen????????????????m1=Sht1.[d65536].End(xlUp).Row????????????????Cells(m1,1).EntireRow.Insertshift:=xlUp????????????????Cells(m1,1)=Cells(m1-1,1)+1????????????????Cells(m1,2)=arr(j,3)????????????????Cells(m1,yf+3)=arr(j,6)??????????????EndIf??????????Nextj??????????wb.Closesavechanges:=False??????????Setwb=Nothing????????EndIf??????EndWith??EndIfNextSetmyFs=NothingApplication.DisplayAlerts=TrueApplication.ScreenUpdating=TrueEndSub
9，多工作簿汇总（FileSearch+字典）
‘http://club.excelhome.net/viewthread.php?tid=504957&pid=3323070&page=1&extra=page%3D1
Subpldrwb1123()
''合并.xls
''导入指定文件的数据
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
Dimi&,n&,y&,bb,j&,x
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm$,nm1$,m,Arr,r1,mm&
Dimd,k,t,d1,t1
Application.ScreenUpdating=False
mm=8
SetSht1=ActiveSheet
Sht1.[a8:h1000].ClearContents
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
.SearchSubFolders=True
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
aa=InStrRev(Filename,"\")
nm=Right(Filename,Len(Filename)-aa)
nm1=Left(nm,Len(nm)-4)
Ifnm1<>"合并"Then
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
m=[a65536].End(xlUp).Row
Arr=Range(Cells(8,1),Cells(m,7))
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Forj=1ToUBound(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
Fory=0ToUBound(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.Closesavechanges:=False
Setwb=Nothing
Setd=Nothing
Setd1=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
EndSub
10，多工作簿多工作表提取数据（DoWhile）
‘http://club.excelhome.net/viewthread.php?tid=511250&pid=3368549&page=1&extra=page%3D1
‘年度汇总.xls
Subndhz()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimm&,funm$,shnm$,col%,i&
Application.ScreenUpdating=False
Setwb=ThisWorkbook
funm="年度汇总.xls"
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Arr=.Sheets("领料").Range("A1").CurrentRegion
ForEachshInwb.Sheets
shnm=sh.Name
sh.Activate
IfInStr(shnm,"班")>0Then
col=11
Else
col=7
EndIf
Fori=2ToUBound(Arr)
IfArr(i,col)=shnmThen
m=sh.[a65536].End(xlUp).Row+1
Cells(m,1).Resize(1,12)=Application.Index(Arr,i,0)
EndIf
Next
Next
.CloseFalse
EndWith
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/viewthread.php?tid=629755&page=1#pid4261137
Subtqsj()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimm&,funm$,shnm$,col%,i&,Myr&,Sht1AsWorksheet,pm$
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
[a2:g1000].ClearContents
funm="提取数据.xls":m=1
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Setwb=Workbooks(myName)
ForEachshInwb.Sheets
shnm=sh.Name
sh.Activate
pm=sh.[a4].Value
Myr=sh.[a65536].End(xlUp).Row
Arr=sh.Range("b9:e"&Myr)
m=m+1
WithSht1
.Cells(m,1)=myName
.Cells(m,2)=pm
.Cells(m,3)=shnm
.Cells(m,4).Resize(UBound(Arr),4)=Arr
EndWith
m=m+UBound(Arr)-1
Next
.CloseFalse
EndWith
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/viewthread.php?tid=521786&pid=3439524&page=1&extra=page%3D1
‘我想要的结果.xls
Subzdgx()
DimArr,myPath$,myName$,shAsWorksheet
Dimm&,funm$,n&,ShtAsWorksheet
Application.ScreenUpdating=False
funm="我想要的结果.xls"
SetSht=ActiveSheet
Sht.[a2:f1000].ClearContents
Sht.[a2:f1000].Borders.LineStyle=xlNone
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
n=2
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Setsh=.Sheets("Sheet1")
m=sh.[a65536].End(xlUp).Row
Arr=sh.Range("a2:f"&m)
Cells(n,1).Resize(m-1,6)=Arr
n=n+m-1
.CloseFalse
EndWith
myName=Dir
Loop
Sht.Range("a2:f"&n-1).Borders.LineStyle=1
Application.ScreenUpdating=True
EndSub
‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=113181&star=1#1455753
‘汇总工作表.xls2010-2-7
Subndhz()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimm&,funm$,shnm$,col%,i&,Myr&,Sht1AsWorksheet
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
funm="汇总工作表.xls":m=1
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Setwb=Workbooks(myName)
ForEachshInwb.Sheets
shnm=sh.Name
sh.Activate
Myr=sh.[a65536].End(xlUp).Row
Arr=sh.Range("a1:c"&Myr)
Fori=1ToUBound(Arr)
IfArr(i,3)>50Then
m=m+1
Sht1.Cells(m,1).Resize(1,3)=Application.Index(Arr,i,0)
Sht1.Cells(m,4)=Arr(i+1,3)
Sht1.Cells(m,5)=Arr(i+2,3)
Sht1.Cells(m,6)=shnm
EndIf
Next
Next
.CloseFalse
EndWith
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/viewthread.php?tid=629755&pid=4261137&page=1&extra=page%3D1
Subndhz()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimm&,funm$,shnm$,col%,i&,Myr&,Sht1AsWorksheet
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
funm="汇总工作表.xls":m=1
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Setwb=Workbooks(myName)
ForEachshInwb.Sheets
shnm=sh.Name
sh.Activate
Myr=sh.[a65536].End(xlUp).Row
Arr=sh.Range("a1:c"&Myr)
Fori=1ToUBound(Arr)
IfArr(i,3)>50Then
m=m+1
Sht1.Cells(m,1).Resize(1,3)=Application.Index(Arr,i,0)
Sht1.Cells(m,4)=Arr(i+1,3)
Sht1.Cells(m,5)=Arr(i+2,3)
Sht1.Cells(m,6)=shnm
EndIf
Next
Next
.CloseFalse
EndWith
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/thread-539493-1-1.html
Subndhz()‘设置工作表在此处要用Sheets("汇总")格式
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimm&,funm$,shnm$,n%,i&,wb1AsWorkbook
Application.ScreenUpdating=False
Setwb=ThisWorkbook
funm="汇总.xls":n=1
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
wb.Sheets("汇总").[a2:e100].Clear
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Setwb1=Workbooks(myName)
Setsh=wb1.Sheets("Sheet1")
m=sh.[a65536].End(xlUp).Row
Withwb.Sheets("汇总")
n=n+1
.Cells(n,1)=sh.[b2].Value
.Cells(n,2)=sh.[c2].Value
.Cells(n,3)=Application.Sum(sh.[e2].Resize(m-1,1))
.Cells(n,4)=Application.Sum(sh.[f2].Resize(m-1,1))
.Cells(n,5)=Application.Sum(sh.[g2].Resize(m-1,1))
EndWith
.CloseFalse
EndWith
myName=Dir
Loop
wb.Sheets("汇总").Range("a2:e"&n).Borders.LineStyle=1
Application.ScreenUpdating=True
EndSub
''http://club.excelhome.net/thread-580459-1-1.html
‘ABC.xls2010-5-28
Subdgzbsj()
DimArr,i&,sh$,n&,myPath$,shnm$,nm$,ad$
DimShtAsWorksheet,m&,Arr1,r1
OnErrorResumeNext
Application.ScreenUpdating=False
myPath=ThisWorkbook.Path&"\"
sh=Dir(myPath&".xls")
WhileNotLen(sh)=0
Ifsh<>ThisWorkbook.NameThen
WithGetObject(myPath&sh)
SetSht=.Sheets("Sheet1")‘要用set以后才能取到数据
m=Sht.[b65536].End(xlUp).Row
Arr=Sht.Range("b3:e"&m)
Arr1=Sht.Range("b4:e"&m)
shnm=Left(sh,Len(sh)-4)
Fori=1ToUBound(Arr,2)
nm=Arr(1,i)
Sheets(nm).Activate
Setr1=Cells.Find(shnm,,,1)
IfNotr1IsNothingThen
Range(r1.Address).Offset(1,0).Resize(UBound(Arr1),1)=Application.Index(Arr1,0,i)
EndIf
Next
EndWith
EndIf
sh=Dir
Wend
Application.ScreenUpdating=True
EndSub
‘2011-7-5
‘http://club.excelhome.net/viewthread.php?tid=738176&pid=5011219&page=1&extra=page%3D1
Subndhz()??DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet??Dimfunm$,nm$,n%,wb1AsWorkbook,r1,col%,Myr&??Application.ScreenUpdating=False??Setwb=ThisWorkbook??funm="总表.xls":n=1??myPath=ThisWorkbook.Path&"\"??myName=Dir(myPath&".xls")??wb.Sheets("Sheet1").Cells.ClearContents??[a2]="产品名"??DoWhilemyName<>""??????IfmyName<>funmThen??????WithGetObject(myPath&myName)????????nm=Left(myName,Len(myName)-4)????????Setwb1=Workbooks(myName)????????Setsh=wb1.Sheets("Sheet1")????????Arr=sh.[a1].CurrentRegion????????Withwb.Sheets("Sheet1")??????????Setr1=.Rows(2).Find(nm,,,1)??????????IfNotr1IsNothingThen??????????????col=r1.Column??????????Else??????????????col=[iv2].End(xlToLeft).Column+1??????????????Cells(2,col)=nm??????????EndIf??????????Fori=2ToUBound(Arr)??????????????Setr1=.[a:a].Find(Arr(i,1),,,1)??????????????IfNotr1IsNothingThen????????????????.Cells(r1.Row,col)=Arr(i,2)??????????????Else????????????????Myr=.[a65536].End(xlUp).Row+1????????????????.Cells(Myr,1)=Arr(i,1)????????????????.Cells(Myr,col)=Arr(i,2)??????????????EndIf??????????Next????????EndWith????????.CloseFalse??????EndWith??????EndIf??????myName=Dir??Loop??Application.ScreenUpdating=TrueEndSub
11，多工作簿提取指定数据（GetOpenFileName）
‘汇总表.xls
‘http://club.excelhome.net/viewthread.php?tid=511349&pid=3369047&page=1&extra=page%3D1
PrivateSubCommandButton1_Click()
DimtmpFileNameAsString,FileNumberAsInteger,cAsRange
DimmyWorkbookAsWorkbook,tmpFileListAsVariant,tmpFileIndexAsLong
DimfAsRange‘上述红字必须声明为Variant，否则下面的Ubound要出错
tmpFileList=Application.GetOpenFilename("DataFile(.xls),.xls",,"确定文件",,True)
IfVarType(tmpFileList)=vbBooleanThen
ExitSub
Else
Application.ScreenUpdating=False
Application.StatusBar="数据处理中，请稍等..."
Application.DisplayAlerts=False
Setf=[a65536].End(xlUp)
FortmpFileIndex=1ToUBound(tmpFileList)
Application.StatusBar=tmpFileIndex&"/"&UBound(tmpFileList)&"处理中"
tmpFileName=tmpFileList(tmpFileIndex)
SetmyWorkbook=Workbooks.Open(tmpFileName,0,vbReadOnly)
WithmyWorkbook
Setc=.Worksheets(1).Range("b:B").Find("销售额")''找到B列中带销售额字样的单元格
Setf=f.Offset(1,0)
f.Value=Left(.Name,Len(.Name)-4)''填入文件名
f.Offset(0,1).Value=c.Offset(0,1).Value''填入销售额的数字
.CloseFalse
EndWith
NexttmpFileIndex
EndIf
Application.StatusBar=False
Application.DisplayAlerts=True
EndSub
12，多工作表汇总（字典）
‘1231228.xls
‘http://club.excelhome.net/thread-518738-1-1.html
模块1：
Publicm%,k1
PrivateSubWorkbook_Open()
Dimd,k,t,Myr&,Arr,i&
Setd=CreateObject("Scripting.Dictionary")
WithSheet3
Myr=.[a65536].End(xlUp).Row
Arr=.Range("a2:e"&Myr)
Fori=1ToUBound(Arr)
d(Arr(i,1))=""
Next
k=d.keys
WithSheet1.[b1].Validation
.Delete
.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_
Operator:=xlBetween,Formula1:=Join(d.keys,",")
EndWith
d.RemoveAll
Setd=CreateObject("Scripting.Dictionary")
Fori=1ToUBound(Arr)
d(Arr(i,4))=""
Next
m=d.Count
k1=d.keys
EndWith
EndSub
PrivateSubWorksheet_Change(ByValTargetAsRange)
IfTarget.Count>1ThenExitSub
IfTarget.Address<>"$B$1"ThenExitSub
Dimd,k,t,Arr,i&,Myr&,x,yf,j&,Arr1
Dimii&,lj,zb,ljs,cp,j1%,y,jj%
Setd=CreateObject("Scripting.Dictionary")
yf=Target.Value
WithSheet2
Myr=.[a65536].End(xlUp).Row
Arr=.Range("a2:e"&Myr)
Fori=1ToUBound(Arr)
x=Arr(i,1)&"|"&Arr(i,4)
d(x)=d(x)+Arr(i,5)
Next
k=d.keys
t=d.items
ReDimArr1(1Tom,1To7)
Forj=0ToUBound(k1)
Forj1=0ToUBound(k)
y=Val(Split(k(j1),"|")(0))
cp=Split(k(j1),"|")(1)
Ifcp=k1(j)Andy=yfThen
Arr1(j+1,1)=k1(j)
Arr1(j+1,3)=t(j1)''本月发货
EndIf
Ifcp=k1(j)Andy
lj=lj+t(j1)''累计发货
EndIf
Next
Arr1(j+1,6)=lj''累计发货
lj=0
Next
EndWith
d.RemoveAll
Setd=CreateObject("Scripting.Dictionary")
WithSheet3
Myr=.[a65536].End(xlUp).Row
Arr=.Range("a2:e"&Myr)
Fori=1ToUBound(Arr)
x=Arr(i,1)&"|"&Arr(i,4)
d(x)=d(x)+Arr(i,5)
Next
k=d.keys
t=d.items
Forj=0ToUBound(k1)
Forj1=0ToUBound(k)
y=Val(Split(k(j1),"|")(0))
cp=Split(k(j1),"|")(1)
Ifcp=k1(j)Andy=yfThen
Arr1(j+1,2)=t(j1)''本月指标
Forii=1ToUBound(k)+1
zb=zb+t(ii-1)''本年指标
Next
Arr1(j+1,5)=zb''本年指标
zb=0
ExitFor
EndIf
Next
Next
EndWith
d.RemoveAll
Setd=CreateObject("Scripting.Dictionary")
WithSheet4
Myr=.[a65536].End(xlUp).Row
Arr=.Range("a2:e"&Myr)
Fori=1ToUBound(Arr)
x=Arr(i,1)&"|"&Arr(i,4)
d(x)=d(x)+Arr(i,5)
Next
k=d.keys
t=d.items
Forj=0ToUBound(k1)
Forj1=0ToUBound(k)
y=Val(Split(k(j1),"|")(0))
cp=Split(k(j1),"|")(1)
Ifcp=k1(j)Andy=yfThen
Arr1(j+1,4)=t(j1)''上年发货
EndIf
Ifcp=k1(j)Andy
ljs=ljs+t(j1)''累计发货
EndIf
Next
Arr1(j+1,7)=ljs''累计发货
ljs=0
Next
EndWith
Sheet1.[c4].Resize(UBound(Arr1),7).ClearContents
Sheet1.[c4].Resize(UBound(Arr1),7)=Arr1
EndSub
13，多工作表不同产量总重量汇总（字典）
‘http://club.excelhome.net/viewthread.php?tid=523576&pid=3452133&page=1&extra=page%3D1
‘计算多个表相同名称的总重量0108.xls
PrivateSubCommandButton1_Click()Dimnm$,nm1$,i&,d,stAsWorksheet,r1,ad$,sul,tnm="各机组投产数量"nm1="材料调价分类明细"??Setd=CreateObject("scripting.dictionary")??Fori=3To[b65536].End(3).Row??????d(""&Cells(i,2))=0‘不重复材料重量置0??Nexti??ForEachstInSheets??????Ifst.Name<>nm1Andst.Name<>nmAndst.Name<>"data"Andst.Name<>"提示"Then????????Setr1=Sheets(nm).Cells.Find(st.Name,,,1)????????IfNotr1IsNothingThen??????????ad=r1.Address‘表格名的地址??????????sul=Sheets(nm).Range(ad).Offset(1,0)‘投产的数量??????????Ifsul<>0Then??????????????Fori=3Tost.[b65536].End(3).Row????????????????d(""&st.Cells(i,3))=d(""&st.Cells(i,3))+st.Cells(i,4)sul??????????????Nexti??????????EndIf????????EndIf??????EndIf??Nextstt=d.items
[f3].Resize(d.Count,1)=Application.Transpose(t)
ExitSub
Fori=3To[b65536].End(3).Row??????Cells(i,6)=d(""&Cells(i,2))??NextiEndSub
14，多工作簿汇总（FileSearch和Dir）
‘2010-5-5
‘汇总表.xls__解决一个月的汇总
Subrmxb0505()
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
Dimi&,n&,r%,Arr1(),rq,sl,rr,yy,Myc%
DimSht1AsWorksheet,shAsWorksheet,yg$,bb
Dimaa,nm1$,m,arr,r1,j&,Rmx,Ymx,Rmxhj
Dimjs,ks,x,y,col%,nm$
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
Myc=[iv2].End(xlToLeft).Column
Range("b3",Cells(33,Myc)).ClearContents
Rmx=Range("b3",Cells(33,Myc))
Sheet2.Activate
Ymx=Range("b3",Cells(14,Myc+3))
Sht1.Activate
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path''&"\发货工作量统计\"
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
.SearchSubFolders=True
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
aa=InStrRev(Filename,"\")
yg=Left(Filename,aa-1)
bb=InStrRev(yg,"\")
yg=Right(yg,Len(yg)-bb)''员工姓名
nm=Right(Filename,Len(Filename)-aa)
nm1=Left(nm,Len(nm)-4)
Ifnm1<>"汇总表"AndRight(nm1,1)="A"OrRight(nm1,1)="a"Then
Workbooks.Openmyfile(i)
r=0
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=wb.Sheets("Sheet1")
sh.Activate
bb=Left(nm1,Len(nm1)-1)
rq=Split(bb,"-")(0)''日期
rr=Val(Right(rq,2))''日
yy=Val(Left(rq,Len(rq)-2))''月
sl=Val(Split(bb,"-")(2))''订单数
Setr1=Sht1.Rows(1).Find(yg,,,1)
IfNotr1IsNothingThen
col=r1.Column-1
Rmx(rr,col)=Rmx(rr,col)+sl''订单总数
EndIf
m=sh.[a65536].End(xlUp).Row
arr=Range("a1:k"&m)
Forj=1ToUBound(arr)
Ifarr(j,1)="仓库配货单"Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=j
EndIf
Next
Forj=1Tor
Ifj<>rThen
js=Arr1(j+1)-1
Else
js=m
EndIf
ks=Arr1(j)+3
Forx=ksTojs
IfTrim(arr(x,2))=""ThenGoTo100
IfInStr(arr(x,2),"注意")>0OrInStr(arr(x,2),"订单明细")>0OrInStr(arr(x,2),"装箱单")>0Then
Else
Rmx(rr,col+1)=Rmx(rr,col+1)+1''配货明细
Rmx(rr,col+2)=Rmx(rr,col+2)+Val(arr(x,8))''配货量数
EndIf
100:
Next
Next
wb.Closesavechanges:=False
Setwb=Nothing
EndIf
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
SetmyFs=Nothing
Sht1.Activate
[b3].Resize(31,UBound(Rmx,2))=Rmx
IfInStr(Sht1.Name,"月")=0Then
Sht1.Name=yy&"月"&Sht1.Name
EndIf
[a1].Select
Rmxhj=Range("b34",Cells(34,Myc))
Fori=1To3UBound(Rmxhj,2)/(Myc-1)''Step3
Ymx(yy,4i-2)=Rmxhj(1,3i-2)
Ymx(yy,4i-1)=Rmxhj(1,3i-1)
Ymx(yy,4i)=Rmxhj(1,3i)
Next
Sheet2.[b3].Resize(12,UBound(Ymx,2))=Ymx
Application.ScreenUpdating=True
EndSub
Subrmxb0505a()
DimmyPathAsString,Filename$,myXL
Dimi&,n&,r%,Arr1(),rq,sl,rr,yy,Myc%
DimSht1AsWorksheet,shAsWorksheet,yg$,bb
Dimaa,nm1$,m,arr,r1,j&,Rmx,Ymx,Rmxhj
Dimjs,ks,x,y,col%,arml
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
Myc=[iv2].End(xlToLeft).Column
arml=Range("b1",Cells(1,Myc))
Range("b3",Cells(33,Myc)).ClearContents
Rmx=Range("b3",Cells(33,Myc))
Sheet2.Activate
Ymx=Range("b3",Cells(14,Myc+3))
Sht1.Activate
Fory=1ToUBound(arml,2)Step3
yg=arml(1,y)
myPath=ThisWorkbook.Path&"\"&yg&"\"
Filename=Dir(myPath&".xls")
DoWhileFilename<>""
aa=myPath&Filename
nm1=Left(Filename,Len(Filename)-4)
bb=Left(nm1,Len(nm1)-1)
rq=Split(bb,"-")(0)''日期
rr=Val(Right(rq,2))''日
yy=Val(Left(rq,Len(rq)-2))''月
Ifnm1<>"汇总表"AndRight(nm1,1)="A"OrRight(nm1,1)="a"Then
Workbooks.Openaa
r=0
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=wb.Sheets("Sheet1")
sh.Activate
sl=Val(Split(bb,"-")(2))''订单数
Setr1=Sht1.Rows(1).Find(yg,,,1)
IfNotr1IsNothingThen
col=r1.Column-1
Rmx(rr,col)=Rmx(rr,col)+sl''订单总数
EndIf
m=sh.[a65536].End(xlUp).Row
arr=Range("a1:k"&m)
Forj=1ToUBound(arr)
Ifarr(j,1)="仓库配货单"Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=j
EndIf
Next
Forj=1Tor
Ifj<>rThen
js=Arr1(j+1)-1
Else
js=m
EndIf
ks=Arr1(j)+3
Forx=ksTojs
IfTrim(arr(x,2))=""ThenGoTo100
IfInStr(arr(x,2),"注意")>0OrInStr(arr(x,2),"订单明细")>0OrInStr(arr(x,2),"装箱单")>0Then
Else
Rmx(rr,col+1)=Rmx(rr,col+1)+1''配货明细
Rmx(rr,col+2)=Rmx(rr,col+2)+Val(arr(x,8))''配货量数
EndIf
100:
Next
Next
wb.Closesavechanges:=False
Setwb=Nothing
EndIf
Filename=Dir
Loop
Next
Sht1.Activate
[b3].Resize(31,UBound(Rmx,2))=Rmx
IfInStr(Sht1.Name,"月")=0Then
Sht1.Name=yy&"月"&Sht1.Name
EndIf
[a1].Select
Rmxhj=Range("b34",Cells(34,Myc))
Fori=1To3UBound(Rmxhj,2)/(Myc-1)
Ymx(yy,4i-2)=Rmxhj(1,3i-2)
Ymx(yy,4i-1)=Rmxhj(1,3i-1)
Ymx(yy,4i)=Rmxhj(1,3i)
Next
Sheet2.[b3].Resize(12,UBound(Ymx,2))=Ymx
Application.ScreenUpdating=True
EndSub
15，多工作簿汇总（FileSearch）by:LongIII
PrivateSubCommandButton1_Click()
DimTwbAsWorkbook,WbAsWorkbook
DimrngAsRange
Dims,Myr&
Application.ScreenUpdating=False
SetTwb=ThisWorkbook
Cells.ClearContents''清除当前表的内容
WithApplication.FileSearch''查找
.LookIn=Twb.Path''范围为此目录下
.Filename=".xls"''查找所有的xls文件
.ExecutemsoSortByFileName''执行查找过程，并且将查询结果按文件名排序
ForEachsIn.FoundFiles''在每一个查找到的结果里
Ifs<>Twb.FullNameThen''假如它不是当前工作簿
SetWb=Workbooks.Open(s)''打开它
Setrng=Range("a65536").End(xlUp).Offset(1,0)''设置变量rng为最后一行的下一行
Wb.Sheets(1).UsedRange.Copyrng''复制新打开的工作簿的第一个工作表的已用区域到rng
Cells(rng.Row,10)=Wb.Name
Wb.CloseFalse''不保存就关闭这个打开的工作簿
EndIf
Next
EndWith
Application.ScreenUpdating=True
EndSub
16，汇总至多工作簿（Move/SaveAs）
''http://club.excelhome.net/thread-598830-1-1.html
Subfb()
Dimi&,Myr&,Myc%,Arr,col%,bt,n&,pa$,nm$
DimSht1AsWorksheet,ShtAsWorksheet
Application.ScreenUpdating=False
pa=ThisWorkbook.Path
SetSht1=ActiveSheet
Myr=[a65536].End(xlUp).Row
Myc=[iv2].End(xlToLeft).Column
Arr=Range("a2",Cells(Myr,Myc))
bt=Array("品牌","类","零","厂址","编号")
Forcol=11ToUBound(Arr,2)
Sheets.Addafter:=Sheets(Sheets.Count)
n=2
SetSht=ActiveSheet
[a1]=Arr(1,col)&"-"&Sht1.[a1].Value
[a2].Resize(1,5)=bt
Cells(n,6)=Arr(1,col)
Fori=2ToUBound(Arr)
IfArr(i,col)<>""Then
n=n+1
Cells(n,1)=Arr(i,1)
Cells(n,2)=Arr(i,7)
Cells(n,3)=Arr(i,8)
Cells(n,4)=Arr(i,9)
Cells(n,5)=Arr(i,10)
Cells(n,6)=Arr(i,col)
EndIf
Next
Range("a2:f"&n).Borders.LineStyle=1
Cells.Select
WithSelection.Font
.Name="宋体"
.Bold=True
.Size=16
EndWith
WithSelection
.HorizontalAlignment=xlCenter
EndWith
Range("A1:F1").Merge
nm=pa&"\"&Arr(1,col)&Sht1.[a1].Value&".xls"
Sht.Move
ActiveWorkbook.SaveAsFilename:=nm
ActiveWorkbook.Close
Next
Application.ScreenUpdating=True
EndSub
17，2007版用Dir至多工作簿子文件夹by:青城
‘http://www.excelpx.com/dispbbs.asp?boardid=5&replyid=1760169&id=108832&page=1&skin=0&Star=1
Submain()DimfpAsStringfp="E:\"Callsearfile(fp,".xls")EndSub
Subsearfile(fpAsString,fkeyAsString)Dimarr1()AsString,i1AsInteger,i2AsInteger,fmIfRight(fp,1)<>"\"Thenfp=fp&"\"IfLen(fkey)<1Thenfkey=".xls"''文件类型省略则仅搜索.xls文件fm=Dir(fp,vbDirectory)DoWhilefm<>""???Iffm<>"."Andfm<>".."Then???????If(GetAttr(fp&fm)AndvbDirectory)=vbDirectoryThen???????????i1=i1+1???????????ReDimPreservearr1(1Toi1)???????????arr1(i1)=fp&fm???????EndIf???????IfRight(fm,4)=fkeyThen???????????Range("A65536").End(xlUp)(2,1)=fp&fm??''将文件路径及名称写入当前工作表的A列???????EndIf???EndIf???fm=DirLoopFori2=1Toi1?Callsearfile(arr1(i2),".xls")NextEndSub
18，用Dir提取多工作簿数据（ADO）
‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=135431&star=1#1862014
‘发料一.xls需要先引用Ado2.7
Sub多工作簿提取数据()
''2010-7-21
DimshAsString,nm$,m%,Myr&,i&,n&,nm1$
Dimsql$,connAsADODB.Connection
DimShtAsWorksheet
SetSht=ActiveSheet
Sht.[a3:m1000].ClearContents
nm1=ThisWorkbook.Name
sh=Dir(ThisWorkbook.Path&"\.xls")
WhileNotLen(sh)=0Andsh<>nm1
Setconn=NewADODB.Connection
nm=ThisWorkbook.Path&"\"&sh
Withconn
.Provider="microsoft.jet.oledb.4.0"
.ConnectionString="ExtendedProperties=''Excel8.0;hdr=yes;imex=1;'';datasource="&nm
.Open
EndWith
sql="selectfrom[生产领用明细表$a2:m1000]"
n=Sht.[a65536].End(xlUp).Row+1
Sht.Cells(n,1).CopyFromRecordsetconn.Execute(sql)
sh=Dir
conn.Close
Wend
Setconn=Nothing
EndSub
19，多工作簿提取指定数据（FileSystemObject）by:一念
‘http://club.excelhome.net/thread-617951-1-1.html
SubGetData()
DimFsoAsObject,Fld
DimrngAsRange,Arr
SetFso=CreateObject("Scripting.FileSystemObject")
ForEachFldInFso.getfolder(ThisWorkbook.Path&"\").subfolders
Arr=GetObject(Fld.Path&"\备用整理.xls").Sheets("明细").Range("W3:X51")
GetObject(Fld.Path&"\备用整理.xls").Close
Setrng=Rows(1).Find(Fld.Name,,,1)(3)‘第3行
rng.Resize(UBound(Arr),2)=Arr
Next
EndSub
‘模版0827.xls
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=911279&page=1#pid6248314
SubGetData()
DimFsoAsObject,Fld,nm,col%,Arr,Myc%,r%,Arr1()
DimwbAsWorkbook,ShtAsWorksheet
Application.ScreenUpdating=False
SetFso=CreateObject("Scripting.FileSystemObject")
SetFld=Fso.getfolder(ThisWorkbook.Path&"\").subfolders("1")
ForEachnmInFld.Files‘先找出应该文件夹里面的文件
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=nm.Name
Next
Fori=1Tor
Setwb=Workbooks.Add
SetSht=wb.Worksheets(1)
ForEachFldInFso.getfolder(ThisWorkbook.Path&"\").subfolders
Arr=GetObject(Fld.Path&"\"&Arr1(i)).Sheets("Sheet1").Range("A1").CurrentRegion
GetObject(Fld.Path&"\"&Arr1(i)).Close
Myc=[iv1].End(xlToLeft).Column
IfMyc<>1Thencol=Myc+1Elsecol=1
Sht.Cells(1,col).Resize(UBound(Arr),UBound(Arr,2))=Arr
Next
wb.SaveAsThisWorkbook.Path&"\"&Arr1(i)
wb.Close
Next
Application.ScreenUpdating=True
EndSub
20，2007版FSO代替FileSearch的方法
‘修改技巧202VBA技巧精粹（FSO）递归进入子文件夹，获得指定后缀文件
DimArr1(),r%,strTmpAsString
FunctionGetFileFolderList(ObjFolder)AsString
DimSubFolders,SubFolder,hz$
DimFiles,File
hz="xls" ‘指定后缀
SetFiles=ObjFolder.Files
IfFiles.Count<>0Then
ForEachFileInFiles
IfRight(File,3)=hzThen
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=File
EndIf
Next
EndIf
SetSubFolders=ObjFolder.SubFolders
IfSubFolders.Count<>0Then
ForEachSubFolderInSubFolders
strTmp=GetFileFolderList(SubFolder)
Next
EndIf
GetFileFolderList=strTmp
EndFunction
SubEnumFolderInfo()
Dimfso,folder,myPath$
r=0
myPath=ThisWorkbook.Path&"\"
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
strTmp=GetFileFolderList(folder)
Sheet3.[m:m].Clear
Sheet3.[m1].Resize(r,1)=Application.Transpose(Arr1)
EndSub
‘http://www.ozgrid.com/forum/showthread.php?t=71409
Subtestit()
DimmyPath$,mvvar,i&
myPath=ThisWorkbook.Path&"\"
mvvar=FileList(myPath)
IfTypeName(mvvar)<>"Boolean"Then
Fori=LBound(mvvar)ToUBound(mvvar)
Debug.Printmvvar(i)
Next
Else
MsgBox"Nofilefound"
EndIf
EndSub
返回指定路径下指定后缀所有的文件，返回一维数组。（不能得到子文件夹的文件）
FunctionFileList(fldr,OptionalfltrAsString=".xls")AsVariant
DimsTempAsString,sHldrAsString
IfRight$(fldr,1)<>"\"Thenfldr=fldr&"\"
sTemp=Dir(fldr&fltr)
IfsTemp=""Then
FileList=False
ExitFunction
EndIf
Do
sHldr=Dir
IfsHldr=""ThenExitDo
sTemp=sTemp&"|"&sHldr
Loop
FileList=Split(sTemp,"|")
EndFunction
‘F:\新发帖\VBA\星河\郭绮华\汇总表.xls
Subrmxb0505a()
DimmyPathAsString,Filename$,myXL
Dimi&,n&,r%,Arr1(),rq,sl,rr,yy,Myc%
DimSht1AsWorksheet,shAsWorksheet,yg$,bb
Dimaa,nm1$,m,arr,r1,j&,Rmx,Ymx,Rmxhj
Dimjs,ks,x,y,col%,arml
Application.ScreenUpdating=False
OnErrorResumeNext
SetSht1=ActiveSheet
Myc=[iv2].End(xlToLeft).Column
arml=Range("b1",Cells(1,Myc))
Range("b3",Cells(33,Myc)).ClearContents
Rmx=Range("b3",Cells(33,Myc))
Sheet2.Activate
Ymx=Range("b3",Cells(14,Myc+3))
Sht1.Activate
Fory=1ToUBound(arml,2)Step3
yg=arml(1,y)
myPath=ThisWorkbook.Path&"\"&yg&"\"
Filename=Dir(myPath&".xls")
DoWhileFilename<>""
aa=myPath&Filename
nm1=Left(Filename,Len(Filename)-4)
bb=Left(nm1,Len(nm1)-1)
rq=Split(bb,"-")(0)''日期
rr=Val(Right(rq,2))''日
yy=Val(Left(rq,Len(rq)-2))''月
Ifnm1<>"汇总表"AndRight(nm1,1)="A"OrRight(nm1,1)="a"Then
Workbooks.Openaa
r=0
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=wb.Sheets("Sheet1")
sh.Activate
sl=Val(Split(bb,"-")(2))''订单数
Setr1=Sht1.Rows(1).Find(yg,,,1)
IfNotr1IsNothingThen
col=r1.Column-1
Rmx(rr,col)=Rmx(rr,col)+sl''订单总数
EndIf
m=sh.[a65536].End(xlUp).Row
arr=Range("a1:k"&m)
Forj=1ToUBound(arr)
Ifarr(j,1)="仓库配货单"Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=j
EndIf
Next
Forj=1Tor
Ifj<>rThen
js=Arr1(j+1)-1
Else
js=m
EndIf
ks=Arr1(j)+3
Forx=ksTojs
IfTrim(arr(x,2))=""ThenGoTo100
IfInStr(arr(x,2),"注意")>0OrInStr(arr(x,2),"订单明细")>0OrInStr(arr(x,2),"装箱单")>0Then
Else
Rmx(rr,col+1)=Rmx(rr,col+1)+1''配货明细
Rmx(rr,col+2)=Rmx(rr,col+2)+Val(arr(x,8))''配货量数
EndIf
100:
Next
Next
wb.Closesavechanges:=False
Setwb=Nothing
EndIf
Filename=Dir
Loop
Next
Sht1.Activate
[b3].Resize(31,UBound(Rmx,2))=Rmx
IfInStr(Sht1.Name,"月")=0Then
Sht1.Name=yy&"月"&Sht1.Name
EndIf
[a1].Select
Rmxhj=Range("b34",Cells(34,Myc))
Fori=1To3UBound(Rmxhj,2)/(Myc-1)
Ymx(yy,4i-2)=Rmxhj(1,3i-2)
Ymx(yy,4i-1)=Rmxhj(1,3i-1)
Ymx(yy,4i)=Rmxhj(1,3i)
Next
Sheet2.[b3].Resize(12,UBound(Ymx,2))=Ymx
Application.ScreenUpdating=True
EndSub
21，不打开工作簿提取指定数据（宏函数）
‘不打开文件读取其他Excel文件的数据.xls
PublicSubGetData()
DimsFullName,sFile,sPath,sSheet,sCellAsString
DimsResultAsString
sFullName=Application.GetOpenFilename''读取数据源文件路径和名称
IfsFullName=FalseThenExitSub''如果放弃选择文件，退出程序
Range("IV2")=sFullName
Range("IV3")=sFullName
Range("IV4")=sFullName
Range("IV3").Replacewhat:="\",replacement:=""''利用通配符替换路径为空，提取文件名称
Range("IV4").Replacewhat:=Range("IV3"),replacement:=""''替换上面提出的文件名称为空，提取文件路径
sFile=Range("IV3").Value''文件名称赋值
sPath=Range("IV4").Value''文件路径赋值
Range("IV2:IV4").ClearContents
sSheet="DataSource"''指定工作表，即在数据源文件中要读取数据的Sheet的名称
OnErrorResumeNext
Forr=1To100''100行数据
Forc=2To11''10列数据，本例对应B:K列
sCell=Cells(r,c).Address''定义需要读取的区域，本例为B1:K100
sResult=GetCellValue(sPath,sFile,sSheet,sCell)
IfErr.Number<>0Then''找不到指定工作表（比如选错了文件）时进行提示
MsgBox"工作表"&sSheet&"不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。",vbCritical
Err.Clear
ExitSub
EndIf
Cells(r,c)=sResult''把读取的数据写入当前文件的B1:K100区域,便于后续查询使用
Next
Next
MsgBox"Done!",vbInformation
EndSub
''调用XLM4.0宏表函数读取指定区域的内容
''如果指定工作表不存在，返回错误
PublicFunctionGetCellValue(sPath,sFile,sSheet,sCell)
GetCellValue=ExecuteExcel4Macro("''"&sPath&"["&sFile&"]"_
&sSheet&"''!"&Range(sCell).Address(,,xlR1C1))
EndFunction
‘http://club.excelhome.net/viewthread.php?tid=725789&page=1#pid4926943
‘2011-6-1Bom总表.rar
放在总表的代码里：PrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Count>1ThenExitSubIfTarget.Address<>"$C$2"ThenExitSubnm=Target.Value[c4:c45]="":[e4:f45]=""CallGetDataEndSub以下代码放在模块1里面：Publicnm$SubGetData()DimsFullName,sFile,sPath,sSheet,sCellAsStringDimsResultAsStringsFile=nm&".xls"??''文件名称赋值sPath=ThisWorkbook.Path&"\"??''文件路径赋值sFullName=Dir(sPath&sFile)IfsFullName=""ThenExitSub??''如果放弃选择文件，退出程序sSheet="Sheet1"??''指定工作表，即在数据源文件中要读取数据的Sheet的名称OnErrorResumeNextForr=4To45??Forc=3To6??Ifc=4ThenGoTo100??sCell=Cells(r,c).Address''定义需要读取的区域，本例为B4:f45??sResult=GetCellValue(sPath,sFile,sSheet,sCell)??IfErr.Number<>0Then''找不到指定工作表（比如选错了文件）时进行提示??????MsgBox"工作表"&sSheet&"不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。",vbCritical??????Err.Clear??????ExitSub??EndIf??Cells(r,c)=sResult??''把读取的数据写入当前文件的B4:f45区域,便于后续查询使用100:??NextNextMsgBox"Done!",vbInformationEndSub''调用XLM4.0宏表函数读取指定区域的内容''如果指定工作表不存在，返回错误PublicFunctionGetCellValue(sPath,sFile,sSheet,sCell)??GetCellValue=ExecuteExcel4Macro("''"&sPath&"["&sFile&"]"_??????&sSheet&"''!"&Range(sCell).Address(,,xlR1C1))EndFunction‘2011-10-17
‘http://club.excelhome.net/thread-775193-1-1.html
‘只适用于2003版本
SubGetData()
DimsFullName,sFile,sPath,sSheet,sCellAsString
DimsResultAsString
Dimi&,Myr&,Myc%,Arr,ad
OnErrorResumeNext
Application.ScreenUpdating=False
ad=Array("$Q$1","$Q$2","$V$1","$V$2","$O$60","$P$60","$Q$60","$R$60","$S$60","$T$60")''要提取单元格的绝对地址，可扩充
sPath=ThisWorkbook.Path&"\"''文件路径赋值
Sheet1.Activate
Arr=[a1].CurrentRegion
Forr=2ToUBound(Arr)
sFile=Arr(r,1)&".xls"''文件名称赋值
sFullName=Dir(sPath&sFile)
IfsFullName=""ThenExitSub''如果放弃选择文件，退出程序
sSheet="Sheet1"''指定工作表，即在数据源文件中要读取数据的Sheet的名称
Forc=0ToUBound(ad)
sCell=ad(c)''定义需要读取的单元格
sResult=GetCellValue(sPath,sFile,sSheet,sCell)
IfErr.Number<>0Then''找不到指定工作表（比如选错了文件）时进行提示
MsgBox"工作表"&sSheet&"不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。",vbCritical
Err.Clear
ExitSub
EndIf
Cells(r,c+2)=sResult''把读取的数据写入当前文件
Next
Next
MsgBox"Done!",vbInformation
Application.ScreenUpdating=True
EndSub
''调用XLM4.0宏表函数读取指定区域的内容
''如果指定工作表不存在，返回错误
PublicFunctionGetCellValue(sPath,sFile,sSheet,sCell)
GetCellValue=ExecuteExcel4Macro("''"&sPath&"["&sFile&"]"_
&sSheet&"''!"&Range(sCell).Address(,,xlR1C1))
EndFunction
22，用FSO取得文件名，宏函数统计指定单元格值
‘2011-11-4
‘http://club.excelhome.net/thread-784939-1-1.html
PublicArr1()
SubGetfiles()
DimFsoAsObject,Fc,f1,myPath$,r%
myPath=ThisWorkbook.Path''
SetFso=CreateObject("Scripting.FileSystemObject")
Setf=Fso.GetFolder(myPath)
SetFc=f.Files
ForEachf1InFc
IfInStr(f1.Name,"表1.xls")=0Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=f1.Name
EndIf
Next
EndSub
SubGetData()
DimsFullName$,sFile$,sPath$,sSheet$,sCell$
DimsResult,ad$,r%
OnErrorResumeNext
Application.ScreenUpdating=False
CallGetfiles
ad="$B$2"
sPath=ThisWorkbook.Path&"\"''文件路径赋值
Sheet1.Activate
Forr=1ToUBound(Arr1)
sFile=Arr1(r)''&".xls"''文件名称赋值
sFullName=Dir(sPath&sFile)
IfsFullName=""ThenExitSub''如果放弃选择文件，退出程序
sSheet="Sheet1"''指定工作表，即在数据源文件中要读取数据的Sheet的名称
sCell=ad''定义需要读取的单元格
sResult=GetCellValue(sPath,sFile,sSheet,sCell)
IfErr.Number<>0Then''找不到指定工作表（比如选错了文件）时进行提示
MsgBox"工作表"&sSheet&"不存在。请确保您选择了正确的文件，且源文件中工作表名称没有被修改。",vbCritical
Err.Clear
ExitSub
EndIf
[b1]=[b1]+sResult''把读取的数据写入当前文件
Next
MsgBox"Done!",vbInformation
Application.ScreenUpdating=True
EndSub
''调用XLM4.0宏表函数读取指定区域的内容
''如果指定工作表不存在，返回错误
PublicFunctionGetCellValue(sPath,sFile,sSheet,sCell)
GetCellValue=ExecuteExcel4Macro("''"&sPath&"["&sFile&"]"_
&sSheet&"''!"&Range(sCell).Address(,,xlR1C1))
EndFunction
23，多工作簿汇总（DoWhile+字典）
‘http://club.excelhome.net/viewthread.php?tid=740844&pid=5036586&page=2&extra=
‘预算对比.xls
Subhz()
DimShtAsWorksheet,col%,k1,t1
Dimi&,Myr&,j&,ii&,Arr,r%,Arr1(),Brr
Dimd,k,t
DimwbAsWorkbook,nm$
DimshAsWorksheet
DimPATHAsString
Dimdirr
Setd=CreateObject("Scripting.Dictionary")
bt=Array("实际数","预算数","实际与预算对比","超支说明","是否有提交申请报告（超支流程流水号）")
nm="经营分析表汇总"
PATH=ThisWorkbook.PATH
dirr=Dir(PATH&"/.xls")
DoWhiledirr<>""
Ifdirr<>ThisWorkbook.NameThen
WithGetObject(PATH&"\"&dirr)
Setwb=Workbooks(dirr)
Setsh=wb.Sheets(nm)
ForEachShtInwb.Sheets
IfInStr(Sht.Name,"店")Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=Sht.Name
Myr=Sht.[b65536].End(xlUp).Row-1
Arr=Sht.Range("a4:c"&Myr)
Fori=1ToUBound(Arr)
IfArr(i,2)<>""Then
d(Arr(i,2))=""
EndIf
Next
EndIf
Next
k=d.keys
t=d.items
ReDimBrr(1Tod.Count,1To5r)
d.RemoveAll
ForEachShtInwb.Sheets
IfInStr(Sht.Name,"店")Then
col=col+1
Myr=Sht.[b65536].End(xlUp).Row
Arr=Sht.Range("a4:f"&Myr)
Fori=1ToUBound(Arr)
IfArr(i,2)<>""Then
d(Arr(i,2))=Arr(i,3)&"|"&Arr(i,5)&"|"&Arr(i,6)
EndIf
Next
k1=d.keys
t1=d.items
d.RemoveAll
Forj=0ToUBound(k1)
Forii=0ToUBound(k)
Ifk1(j)=k(ii)Then
Brr(ii+1,5col-4)=Split(t1(j),"|")(0)
Brr(ii+1,5col-3)=Split(t1(j),"|")(1)
Brr(ii+1,5col-2)=Split(t1(j),"|")(2):ExitFor
EndIf
Next
Next
EndIf
Next
wb.CloseFalse
EndWith
EndIf
dirr=Dir
Loop
[a4:iv1000].ClearContents
[a4:iv1000].Borders.LineStyle=xlNone
[b2:iv3].ClearContents
[a4].Resize(UBound(k)+1,1)=Application.Transpose(k)
Fori=1Tor
Cells(2,5i-3)=Arr1(i)
Cells(2,5i-3).Resize(1,5).Merge
Cells(3,5i-3).Resize(1,5)=bt
Next
[b4].Resize(UBound(Brr),5r)=Brr
[a4].Resize(UBound(Brr),5r+1).Borders.LineStyle=1
EndSub
‘http://club.excelhome.net/viewthread.php?tid=750050&pid=5094852&page=1&extra=page%3D1
Subzdgx()
DimArr,myPath$,myName$,shAsWorksheet
Dimm&,funm$,n&,ShtAsWorksheet
Dimd,k,t,Brr
Setd=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
funm="汇总表.xls"
SetSht=ActiveSheet
Sht.[a2:c1000].ClearContents
Sht.[a2:c1000].Borders.LineStyle=xlNone
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
n=2
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Setsh=.Sheets("Sheet1")
m=sh.[a65536].End(xlUp).Row
Arr=sh.Range("a2:c"&m)
Fori=1ToUBound(Arr)
x=Arr(i,1)&"|"&Arr(i,2)
d(x)=d(x)+Arr(i,3)
Next
.CloseFalse
EndWith
myName=Dir
Loop
k=d.keys
t=d.items
ReDimBrr(1Tod.Count,1To3)
Fori=0ToUBound(k)
Brr(i+1,1)=Split(k(i),"|")(0)
Brr(i+1,2)=Split(k(i),"|")(1)
Brr(i+1,3)=t(i)
Next
Sht.Range("a2").Resize(d.Count,3)=Brr
Sht.Range("a1:c"&d.Count+1).Borders.LineStyle=1
Setd=Nothing
Application.ScreenUpdating=True
EndSub
24，多文件夹多工作簿汇总（searchfile）适用07版
‘2011/9/7
‘http://club.excelhome.net/thread-759741-1-1.html
PublicBrr(),r&
Submain()
DimfpAsString,Arr,i&,nm$,Myr&,j&,r1,r2,col%
DimShtAsWorksheet,shAsWorksheet
Application.ScreenUpdating=False
fp=ThisWorkbook.Path&"\"
Callsearfile(fp,".xls")
nm=month([a1].Value)&"月"
SetSht=ActiveSheet
[c4:c1000].ClearContents
Myr=[a65536].End(xlUp).Row
Arr=Range("a4:a"&Myr)
Fori=1ToUBound(Brr,2)
Workbooks.OpenBrr(1,i)&Brr(2,i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=wb.Sheets(nm)
Setr2=sh.Cells.Find("合计")
col=r2.Column
Forj=4ToMyr
IfSht.Cells(j,1).Interior.ColorIndex<>45Then
IfSht.Cells(j,1)<>""Then
Setr1=sh.[b:b].Find(Arr(j-3,1),,,1)
IfNotr1IsNothingThen
Sht.Cells(j,3)=Sht.Cells(j,3)+sh.Cells(r1.Row,col)
EndIf
EndIf
EndIf
Next
wb.Closesavechanges:=False
Setwb=Nothing
Next
Application.ScreenUpdating=True
EndSub
Subsearfile(fpAsString,fkeyAsString)
DimArr1()AsString,i1AsInteger,i2AsInteger,fm
IfRight(fp,1)<>"\"Thenfp=fp&"\"
IfLen(fkey)<1Thenfkey=".xls"''文件类型省略则仅搜索.xls文件
fm=Dir(fp,vbDirectory)
DoWhilefm<>""
Iffm<>"."Andfm<>".."Then
If(GetAttr(fp&fm)AndvbDirectory)=vbDirectoryThen
i1=i1+1
ReDimPreserveArr1(1Toi1)
Arr1(i1)=fp&fm
EndIf
IfRight(fm,Len(fkey))=fkeyThen
r=r+1
ReDimPreserveBrr(1To2,1Tor)
Brr(1,r)=fp
Brr(2,r)=fm
EndIf
EndIf
fm=Dir
Loop
Fori2=1Toi1
Callsearfile(Arr1(i2),fkey)
Next
EndSub
25，多工作簿汇总（带超链接）
‘http://www.excelpx.com/thread-206109-1-1.html
Sub汇总()
DimArr(),myPath$,myName$,SHAsWorksheet
DimI%,J%,N&
Application.ScreenUpdating=False
Range("A2:L"&Range("E65536").End(xlUp).Row+1).ClearContents
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
N=1
DoWhilemyName<>""AndmyName<>ThisWorkbook.Name
ReDimPreserveArr(1To12,1ToN)
WithGetObject(myPath&myName)
SetSH=.Sheets("Sheet1")
Arr(1,N)=Split(myName,".")(0)
Arr(2,N)=SH.Range("F3")
Arr(3,N)=SH.Range("B3")
Arr(4,N)=SH.Range("B4")
ForI=7ToSH.Range("B7").End(xlDown).Row
ForJ=1To8
Arr(J+4,N)=SH.Cells(I,J)
Next
N=N+1
ReDimPreserveArr(1To12,1ToN)
Next
.CloseFalse
EndWith
myName=Dir
Loop
Range("A2").Resize(N,12)=Application.Transpose(Arr)
Range("A2").Resize(N,12).Borders.LineStyle=1
ForI=2ToRange("A65536").End(3).Row
IfRange("A"&I)<>""ThenActiveSheet.Hyperlinks.AddAnchor:=Range("A"&I),_
Address:=myPath&Range("A"&I)&".xls",TextToDisplay:=Range("A"&I).Value
Next
Application.ScreenUpdating=True
EndSub
26，多工作簿提取指定列数据的五种方法
‘http://club.excelhome.net/thread-787609-1-1.html
SubCopyData_1()
‘宏公式
DimTempAsString
Temp="''"&ThisWorkbook.Path&"\库存出入库总帐.xls]Sheet2''!"
WithSheet2.Range("A5:s22")
.FormulaR1C1="="&Temp&"RC"
.Value=.Value
EndWith
EndSub
SubCopyData_2()
‘GetObject方法
DimWbAsWorkbook
DimTempAsString
Application.ScreenUpdating=False
Temp=ThisWorkbook.Path&"\库存出入库总帐.xls"
SetWb=GetObject(Temp)
WithWb.Sheets(1).Range("A1").CurrentRegion
Range("A1").Resize(.Rows.Count,.Columns.Count)=.Value
Wb.CloseFalse
EndWith
SetWb=Nothing
Application.ScreenUpdating=True
EndSub
SubCopyData_3()
‘NewApplication方法
DimmyAppAsNewApplication
DimShAsWorksheet
DimTempAsString
Temp=ThisWorkbook.Path&"\库存出入库总帐.xls"
myApp.Visible=False
SetSh=myApp.Workbooks.Open(Temp).Sheets(2)
WithSh.Range("A1").CurrentRegion
Range("A1").Resize(.Rows.Count,.Columns.Count)=.Value
EndWith
myApp.Quit
SetSh=Nothing
SetmyApp=Nothing
EndSub
SubCopyData_4()
‘Excel4Macro方法
DimRCountAsLong
DimCCountAsLong
DimTempAsString
DimTemp1AsString
DimTemp2AsString
DimTemp3AsString
DimRAsLong
DimCAsLong
Dimarr()AsVariant
Temp="''"&ThisWorkbook.Path&"\[库存出入库总帐.xls]Sheet2''!"
Temp1=Temp&Rows(1).Address(,,xlR1C1)
Temp1="Counta("&Temp1&")"
CCount=Application.ExecuteExcel4Macro(Temp1)
Temp2=Temp&Columns("A").Address(,,xlR1C1)
Temp2="Counta("&Temp2&")"
RCount=Application.ExecuteExcel4Macro(Temp2)
ReDimarr(1ToRCount,1ToCCount)
ForR=1ToRCount
ForC=1ToCCount
Temp3=Temp&Cells(R,C).Address(,,xlR1C1)
arr(R,C)=Application.ExecuteExcel4Macro(Temp3)
Next
Next
Range("A1").Resize(RCount,CCount).Value=arr
EndSub
SubCopyData_5()
‘ADO方法
DimSqlAsString
DimjAsInteger
DimRAsInteger
DimCnnAsADODB.Connection
DimrsAsADODB.Recordset
WithSheet12
.ragne("a5:s2000").Clear
SetCnn=NewADODB.Connection
WithCnn
.Provider="microsoft.jet.oledb.4.0"
.ConnectionString="ExtendedProperties=Excel8.0;"_
&"DataSource="&ThisWorkbook.Path&"\库存出入库总帐"
.Open
EndWith
Setrs=NewADODB.Recordset
Sql="selectfrom[Sheet2$]"
rs.OpenSql,Cnn,adOpenKeyset,adLockOptimistic
Forj=0Tors.Fields.Count-1
.Cells(1,j+1)=rs.Fields(j).Name
Next
R=.Range("A65536").End(xlUp).Row
.Range("A"&R+1).CopyFromRecordsetrs
EndWith
rs.Close
Cnn.Close
Setrs=Nothing
SetCnn=Nothing
EndSub
27，2007版FSO方法（可搜索子文件夹）
‘2015-1-15
http://club.excelhome.net/thread-1170796-2-1.html
‘用字典判断文件是否存在
PrivateSubWorksheet_BeforeDoubleClick(ByValTargetAsRange,CancelAsBoolean)
IfTarget.Column<>6OrTarget.Row<2ThenExitSub
Dimd,nm1$,myPath$,folder,Filename$
Cancel=True
nm=Target.Value:m=Target.Row
Setd=CreateObject("Scripting.Dictionary")
myPath=ThisWorkbook.Path&"\存放\"
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
strTmp=GetFileFolderList(folder)
Fori=1Tor
Filename=Arr1(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
d(nm1)=""
Next
Ifd.exists(nm)Then
MsgBox"文件已经存在！"
Else
Calllqxs1(nm,m)
EndIf
EndSub
‘2012-9-10
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=917464&page=1#pid6289108
PublicArr1(),r%,strTmp$,nm$
FunctionGetFileFolderList(ObjFolder)AsString
DimSubFolders,SubFolder,hz$
DimFiles,File
hz="xls"''指定后缀
SetFiles=ObjFolder.Files
IfFiles.Count<>0Then
ForEachFileInFiles
IfInStr(File,hz)Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=File
EndIf
Next
EndIf
SetSubFolders=ObjFolder.SubFolders
IfSubFolders.Count<>0Then
ForEachSubFolderInSubFolders
strTmp=GetFileFolderList(SubFolder)
Next
EndIf
GetFileFolderList=strTmp
EndFunction
Sublqxs()
Dimfso,folder,myPath$,Filename$,wb1AsWorkbook,m&,Arr
DimSht1AsWorksheet,i&,nm1$,wbnm$,shAsWorksheet,Myr&,Myc&
Application.ScreenUpdating=False
r=0
myPath=ThisWorkbook.Path&"\"
Setwb1=ThisWorkbook
a=InStr(wb1.Name,".")
wbnm=Left(wb1.Name,a-1)
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
strTmp=GetFileFolderList(folder)
Fori=1Tor
Filename=Arr1(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
IfInStr(nm1,wbnm)OrInStr(nm1,"$")ThenGoTo200
IfInStr(nm1,"统计表")Then
Workbooks.OpenFilename
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=wb.Sheets("销售数量明细表")
Arr=sh.[a1].CurrentRegion
wb.Closesavechanges:=False
Setwb=Nothing
Forj=4ToUBound(Arr,2)
Setr1=Rows(1).Find(Arr(1,j),,,1)
IfNotr1IsNothingThen
Myc=r1.Column
Else
Myc=[iv1].End(xlToLeft).Column+1
Cells(1,Myc)=Arr(1,j)
Cells(2,Myc)="销售数量"
EndIf
Fory=3ToUBound(Arr)
Setr1=[b:b].Find(Arr(y,2),,,1)
IfNotr1IsNothingThen
Cells(r1.Row,Myc)=Arr(y,j)
Else
Myr=[a65536].End(xlUp).Row+1
Cells(Myr,1)=Cells(Myr-1,1)+1
Cells(Myr,2)=Arr(y,2)
Cells(Myr,3)=Arr(y,3)
Cells(Myr,4)=Arr(y,j)
EndIf
Next
Next
EndIf
200:
Next
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/thread-825727-1-1.html
‘2012-2-14
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=829023&page=2
‘2012-2-22
PrivateSubWorksheet_Change(ByValTargetAsRange)
IfTarget.Count>1Or[a1].Value=""ThenExitSub
IfTarget.Address<>"$A$1"ThenExitSub
nm=Target.Value
Callyy
EndSub
模块1代码：
PublicArr1(),r%,strTmp$,nm$
FunctionGetFileFolderList(ObjFolder)AsString
DimSubFolders,SubFolder,hz$
DimFiles,File
hz="xls"''指定后缀
SetFiles=ObjFolder.Files
IfFiles.Count<>0Then
ForEachFileInFiles
IfInStr(File,hz)Then
r=r+1
ReDimPreserveArr1(1Tor)
Arr1(r)=File
EndIf
Next
EndIf
SetSubFolders=ObjFolder.SubFolders
IfSubFolders.Count<>0Then
ForEachSubFolderInSubFolders
strTmp=GetFileFolderList(SubFolder)
Next
EndIf
GetFileFolderList=strTmp
EndFunction
Subyy()
Dimfso,folder,myPath$,Filename$,wb1AsWorkbook,m&,Arr
DimSht1AsWorksheet,i&,nm1$,wbnm$,shAsWorksheet,Myr&,Myc&
Application.ScreenUpdating=False
r=0
myPath=ThisWorkbook.Path&"\"
Setwb1=ThisWorkbook
a=InStr(wb1.Name,".")
wbnm=Left(wb1.Name,a-1)
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
strTmp=GetFileFolderList(folder)
Fori=1Tor
Filename=Arr1(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
IfInStr(nm1,wbnm)OrLeft(nm1,1)="$"ThenGoTo200
Workbooks.OpenFilename
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInwb.Sheets
Myr=sh.[b65536].End(xlUp).Row
Myc=sh.[iv2].End(xlToLeft).Column
nm=sh.Name
IfMyr>2Then
Arr=sh.Range("a3",sh.Cells(Myr,Myc))‘特别要注意加对象sh
Withwb1.Sheets(nm1)
m=.[b65536].End(xlUp).Row+1
.Cells(m,1).Resize(UBound(Arr),UBound(Arr,2))=Arr
EndWith
EndIf
Next
wb.Closesavechanges:=False
Setwb=Nothing
200:
Next
Application.ScreenUpdating=True
EndSub
Subyy()
‘2012-7-5
‘http://club.excelhome.net/thread-889839-1-1.html
Dimfso,folder,myPath$,Filename$,wb1AsWorkbook,m&,Arr,n&,c%
DimSht1AsWorksheet,i&,nm1$,wbnm$,shAsWorksheet,Myr&,Myc&,Brr
Application.ScreenUpdating=False
r=0
myPath=ThisWorkbook.Path&"\数据文件\"
Setwb1=ThisWorkbook
a=InStr(wb1.Name,".")
wbnm=Left(wb1.Name,a-1)
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
strTmp=GetFileFolderList(folder)
Fori=1Tor
Filename=Arr1(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
IfInStr(nm1,wbnm)OrInStr(nm1,"$")ThenGoTo200
n=n+1
Cells(n,1)=nm1
200:
Next
[a1].Resize(n,1).Sort[a1],1
Brr=[a1].Resize(n,1)
[a:a].Clear
Fori=1Ton
Filename=myPath&Format(Brr(i,1),"00")&".xlsx"
Workbooks.OpenFilename
DimwbAsWorkbook
Setwb=ActiveWorkbook
ForEachshInwb.Sheets
Myr=sh.[a65536].End(xlUp).Row
Myc=10
nm=sh.Name
IfMyr>2Then
Arr=sh.Range("a1",sh.Cells(Myr,Myc))
Withwb1.Sheets(nm)
c=.[zz1].End(xlToLeft).Column+1
Ifc<10Thenc=1
.Cells(1,c).Resize(UBound(Arr),UBound(Arr,2))=Arr
EndWith
EndIf
Next
wb.Closesavechanges:=False
Setwb=Nothing
Next
Application.ScreenUpdating=True
EndSub
‘2007版本
‘http://club.excelhome.net/thread-822606-1-1.html
Subyy()
Dimfso,folder,myPath$,Filename$,wb1AsWorkbook,m&,Arr
DimSht1AsWorksheet,i&,nm1$,wbnm$,shAsWorksheet,Myr&,Myc&
Application.ScreenUpdating=False
r=0
myPath=ThisWorkbook.Path&"\"
Setwb1=ThisWorkbook
a=InStr(wb1.Name,".")
wbnm=Left(wb1.Name,a-1)
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
strTmp=GetFileFolderList(folder)
Fori=1Tor
Filename=Arr1(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
IfInStr(nm1,wbnm)OrLeft(nm1,1)="$"ThenGoTo200
Workbooks.OpenFilename
DimwbAsWorkbook
Setwb=ActiveWorkbook
Setsh=wb.Sheets("过渡")
Arr=sh.Range("a2:aw2")
Withwb1.Sheets(1)
m=.[b65536].End(xlUp).Row+1
.Cells(m,1).Resize(1,UBound(Arr,2))=Arr
EndWith
wb.Closesavechanges:=False
Setwb=Nothing
200:
Next
Application.ScreenUpdating=True
EndSub
28，2007版FSO方法搜索文件夹文件
‘2014-12-17
‘http://www.excelpx.com/thread-336169-1-1.html
Sublqxs()
Dimfso,folder,myPath$,hz$,shAsWorksheet
Dimi&,nm1$,Files,File,r%,c%
Application.ScreenUpdating=False
Sheet1.Activate
cwells.ClearContents
hz="xls"
[a1].Resize(1,3)=Array("文件夹","工作簿名","工作表名")
r=1
myPath=ThisWorkbook.Path&"\"
Setfso=CreateObject("Scripting.FileSystemObject")
ForEachmyfolInfso.GetFolder(myPath).SubFolders
SetFiles=myfol.Files
IfFiles.Count<>0Then
ForEachFileInFiles
IfInStr(File,hz)Then
r=r+1
Cells(r,1)=myfol.Name
nm1=Mid(File,InStrRev(File,"\")+1)
Cells(r,2)=nm1:c=2
WithGetObject(File)
ForEachshIn.Sheets
c=c+1
Cells(r,c)=sh.Name
Next
.CloseFalse
EndWith
EndIf
Next
EndIf
Next
Setfolder=fso.GetFolder(myPath)
Cells(r+1,1)=folder.Name
SetFiles=folder.Files
IfFiles.Count<>0Then
ForEachFileInFiles
IfInStr(File,hz)Then
r=r+1
nm1=Mid(File,InStrRev(File,"\")+1)
Cells(r,2)=nm1:c=2
WithGetObject(File)
ForEachshIn.Sheets
c=c+1
Cells(r,c)=sh.Name
Next
.CloseFalse
EndWith
EndIf
Next
EndIf
EndSub
‘http://club.excelhome.net/thread-883319-1-1.html
‘2012-6-20
Subyy()
Dimfso,folder,myPath$,hz$
Dimi&,nm1$,Files,File,r%,Arr1()
Application.ScreenUpdating=False
hz="txt"
r=0
myPath=ThisWorkbook.Path&"\数据\"
Setfso=CreateObject("Scripting.FileSystemObject")
Setfolder=fso.GetFolder(myPath)
SetFiles=folder.Files
IfFiles.Count<>0Then
ForEachFileInFiles
IfInStr(File,hz)Then
r=r+1
ReDimPreserveArr1(1Tor)
nm1=Mid(File,InStrRev(File,"\")+1)
Arr1(r)=nm1
EndIf
Next
EndIf
WithSheet1.[a1].Validation
.Delete
.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_
Operator:=xlBetween,Formula1:=Join(Arr1,",")
EndWith
EndSub
29，2007版FSO方法多工作簿汇总
‘2012-9-9
‘http://club.excelhome.net/thread-917579-1-1.html
Sublqxs()
DimFsoAsObject,Fld,Fl,nm,col%,Arr,Myc%,r1,Myr&,i&,j&,y&
Application.ScreenUpdating=False
SetFso=CreateObject("Scripting.FileSystemObject")
SetFld=Fso.getfolder(ThisWorkbook.Path&"\").subfolders
ForEachFlInFld
ForEachnmInFl.Files
IfInStr(nm.Name,"$")ThenGoTo100
Arr=GetObject(Fl.Path&"\"&nm.Name).Sheets(1).Range("A1").CurrentRegion
GetObject(Fl.Path&"\"&nm.Name).Close
IfNotIsArray(Arr)ThenGoTo100
Forj=4ToUBound(Arr,2)
Setr1=Rows(1).Find(Arr(1,j),,,1)
IfNotr1IsNothingThen
Myc=r1.Column
Else
Myc=[iv1].End(xlToLeft).Column+1
Cells(1,Myc)=Arr(1,j)
Cells(2,Myc)="销售数量"
EndIf
Fory=3ToUBound(Arr)
Setr1=[b:b].Find(Arr(y,2),,,1)
IfNotr1IsNothingThen
Cells(r1.Row,Myc)=Arr(y,j)
Else
Myr=[a65536].End(xlUp).Row+1
Cells(Myr,1)=Cells(Myr-1,1)+1
Cells(Myr,2)=Arr(y,2)
Cells(Myr,3)=Arr(y,3)
Cells(Myr,4)=Arr(y,j)
EndIf
Next
Next
Next
100:
Next
Application.ScreenUpdating=True
EndSub
30，多工作簿汇总(GetObject)
‘2016/7/15
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1288978&page=1#pid8739042
Sublqxs()
DimArr,myPath$,myName$,Arr1,Myr&,m&
DimshAsWorksheet,nm$,ShtAsWorksheet
Application.ScreenUpdating=False
Application.DisplayAlerts=False
SetSht=Sheets("合并")
Sht.Activate
Cells.Clear
ForEachshInSheets
Ifsh.Name<>"合并"Thensh.Delete
Next
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xlsx")
DoWhilemyName<>""
IfInStr(myName,"合并")=0Then
WithGetObject(myPath&myName)
nm=Split(myName,".")(0)
Sheets.Addafter:=Sheets(Sheets.Count)
ActiveSheet.Name=nm
ForEachshIn.Sheets
Arr=sh.Range("a1").CurrentRegion
Arr1=sh.Range("A2").Resize(UBound(Arr)-1,UBound(Arr,2))
WithActiveSheet
m=.[a65536].End(xlUp).Row+1
Ifm<=2Thenm=1
Ifm=1Then
.Cells(m,1).Resize(UBound(Arr),UBound(Arr,2))=Arr
Else
.Cells(m,1).Resize(UBound(Arr1),UBound(Arr1,2))=Arr1
EndIf
EndWith
Myr=Sht.[a65536].End(xlUp).Row+1
IfMyr<=2ThenMyr=1
IfMyr=1Then
Sht.Cells(Myr,1).Resize(UBound(Arr),UBound(Arr,2))=Arr
Else
Sht.Cells(Myr,1).Resize(UBound(Arr1),UBound(Arr1,2))=Arr1
EndIf
Next
.CloseFalse
EndWith
EndIf
myName=Dir
Loop
Application.DisplayAlerts=True
Application.ScreenUpdating=True
EndSub
‘2014-10-1
‘http://club.excelhome.net/thread-1155861-1-1.html?jdfwkey=0zauo3
Dimd,d1
Sublqxs()
DimmyPath$,myName$,Arr1
Dimi&,x$,k,t,Arr
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
Sheet1.Activate
[a2:h5000].ClearContents
[a2:h5000].Borders.LineStyle=xlNone
myPath=ThisWorkbook.Path&"\"
myName="订单列表.xlsx"
WithGetObject(myPath&myName)
Arr1=.Sheets(1).Range("A1").CurrentRegion
Fori=2ToUBound(Arr1)
x=Arr1(i,2)&","&Arr1(i,3)
d(x)=d(x)+Arr1(i,4)
Next
.CloseFalse
EndWith
k=d.keys:t=d.items
[b2].Resize(d.Count)=Application.Transpose(k)
[f2].Resize(d.Count)=Application.Transpose(t)
Application.DisplayAlerts=False
[b2].Resize(d.Count).TextToColumnsDataType:=xlDelimited,Comma:=True,FieldInfo_
:=Array(Array(1,2),Array(2,2))
[a2]=1:[a3]=2:[a2:a3].AutoFill[a2].Resize(d.Count)
[a1].CurrentRegion.Borders.LineStyle=1
Arr=Range("A1").CurrentRegion
Fori=2ToUBound(Arr)
x=Arr(i,2)&","&Arr(i,3)
d1(x)=i
Next
Callhz
Application.DisplayAlerts=True
Application.ScreenUpdating=True
EndSub
Subhz()
DimmyPath$,myName$,Arr1,nm,col,aa,x$
col=Array(4,5,7,8)
c=Array(Array(3,4,5),Array(1,2,3),Array(2,3,4),Array(2,3,4))
nm=Array("2013发货汇总","期初库存","发货列表","生产下单")
myPath=ThisWorkbook.Path&"\"
Fori=0ToUBound(nm)
myName=Dir(myPath&nm(i)&".xlsx")
WithGetObject(myPath&myName)
Arr1=.Sheets(1).Range("A1").CurrentRegion
aa=c(i)
Forj=2ToUBound(Arr1)
x=Arr1(j,aa(0))&","&Arr1(j,aa(1))
Ifd1.exists(x)Then
Cells(d1(x),col(i))=Cells(d1(x),col(i))+Arr1(j,aa(2))
EndIf
Next
.CloseFalse
EndWith
Next
EndSub
‘2013-3-29
Sublqxs()
DimArr,myPath$,myName$,Arr1,Myr&
Application.ScreenUpdating=False
Sheet1.Activate
[a2:bz5000].ClearContents
myPath=ThisWorkbook.Path&"\提取工作簿里的工作表\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""
WithGetObject(myPath&myName)
Arr1=.Sheets(1).Range("A1").CurrentRegion
Arr=.Sheets(1).Range("A2").Resize(UBound(Arr1)-1,UBound(Arr1,2))
.CloseFalse
EndWith
Myr=[a65536].End(xlUp).Row+1
Cells(Myr,1).Resize(UBound(Arr),UBound(Arr,2))=Arr
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘2012-10-27多工作簿多工作表汇总
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=936361&page=1#pid6418468
Sublqxs()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimfunm$,i&,d(2),nm,m&
Application.ScreenUpdating=False
Fori=0To2
Setd(i)=CreateObject("Scripting.Dictionary")
Next
Setwb=ThisWorkbook
funm="汇总.xlsm"
nm=Array("大班","中班","小班")
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xlsx")
DoWhilemyName<>""
IfmyName<>funmThen
WithGetObject(myPath&myName)
ForEachshIn.Sheets
arr=sh.Range("b5").CurrentRegion
m=Application.Match(sh.Name,nm,0)-1
Fori=1ToUBound(arr)
d(m)(arr(i,1))=""
Next
Next
.CloseFalse
EndWith
EndIf
myName=Dir
Loop
Fori=0To2
Sheets(nm(i)).[b5].Resize(100,1).ClearContents
Sheets(nm(i)).[b5].Resize(d(i).Count,1)=Application.Transpose(d(i).keys)
Next
Application.ScreenUpdating=True
EndSub
‘2012-12-31
‘http://club.excelhome.net/thread-964827-1-2.html
Publiccs$,mm&
Sublqxs()
DimmyPath$,myName$,Arr1
Dimi&,Brr,nm$
Application.ScreenUpdating=False
Cells(mm,2).Select
nm=Selection(1,1).Value
Cells(mm,4).Select
myPath=ThisWorkbook.Path&"\"
myName=cs&".xls"
WithGetObject(myPath&myName)
Arr1=.Sheets(1).Range("A1").CurrentRegion
Brr=.Sheets(1).Range("b1").Resize(UBound(Arr1),12)
.CloseFalse
EndWith
Fori=3ToUBound(Arr1)
IfArr1(i,1)=nmThen
Cells(mm,4).Resize(1,12)=Application.Index(Brr,i,0)
ExitSub
EndIf
Next
Application.ScreenUpdating=True
EndSub
‘2012-9-21
‘http://club.excelhome.net/forum-2-1.html
Sublqxs()
DimArr,myPath$,myName$,wbAsWorkbook,Arr1
Dimm&,funm$,col%,i&,Brr,d,n&
Application.ScreenUpdating=False
Setd=CreateObject("Scripting.Dictionary")
Setwb=ThisWorkbook
funm="huizong.xlsm"
Sheet1.Activate
Arr=[b2].CurrentRegion
Fori=2ToUBound(Arr)
d(Arr(i,1))=i
Next
col=2
myPath=ThisWorkbook.Path&"\分表\"
myName=Dir(myPath&".xlsx")
DoWhilemyName<>""AndmyName<>funm
WithGetObject(myPath&myName)
Arr1=.Sheets(1).Range("A1").CurrentRegion
.CloseFalse
EndWith
ReDimBrr(1ToUBound(Arr))
Brr(1)=Split(Mid(myName,InStrRev(myName,"\")+1),".")(0)
Fori=3ToUBound(Arr1)
Ifd.exists(Arr1(i,1))Then
n=d(Arr1(i,1))
Brr(n)=Arr1(i,2)
EndIf
Next
col=col+1
Cells(2,col).Resize(UBound(Arr),1)=Application.Transpose(Brr)
EraseBrr
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘2012-9-23
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=924305&page=1#pid6330929
Sublqxs()
''批量导入指定文件的数据
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,ma&,mc&
DimiAsLong,nAsLong,nn&,aa$,nm$,nm1$
DimSht1AsWorksheet,shAsWorksheet
Application.ScreenUpdating=False
nm=ThisWorkbook.Name
nm=Left(nm,Len(nm)-4)
SetSht1=ActiveSheet
Sht1.[a2:m5000]=""
SetmyFs=Application.FileSearch
myPath=ThisWorkbook.Path&"\绩效管理"''指定的子文件夹内搜索
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename=".xls"
.SearchSubFolders=True
If.Execute(SortBy:=msoSortByFileName)>0Then
n=.FoundFiles.Count
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
nm1=Split(Mid(Filename,InStrRev(Filename,"\")+1),".")(0)
Ifnm1<>nmThen
DimwbAsWorkbook
Setwb=Workbooks.Open(myfile(i))
aRow=wb.Sheets(1).Range("a5000").End(xlUp).Row
tRow=Sht1.Range("a5000").End(xlUp).Row+1
wb.Sheets(1).Range("a3:m"&aRow).CopySht1.Range("a"&tRow)
wb.CloseFalse
EndIf
Setwb=Nothing
Next
Else
MsgBox"该文件夹里没有任何文件"
EndIf
EndWith
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
EndSub
‘2013-9-1
‘http://club.excelhome.net/thread-1052034-1-1.html
Sublqxs()
DimArr,myPath$,myName$,Arr1,Myr&,d,j&
Dimm&,col,nm$,n&
Setd=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
nm=ThisWorkbook.Name
Sheet1.Activate
[b3:bl5000].ClearContents
Arr=[a1].CurrentRegion
Fori=3ToUBound(Arr)
d(Arr(i,1))=i
Next
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""
IfmyName<>nmThen
col=Split(Split(myName,".")(0),"-")(2)+1
WithGetObject(myPath&myName)
Arr1=.Sheets(1).Range("A1").CurrentRegion
Forj=1ToUBound(Arr1,2)Step4
Ifd.exists(Arr1(1,j))Then
m=d(Arr1(1,j))
Cells(m,col)=Arr1(1,j+1)
Cells(m,col+32)=Arr1(1,j+3)
Fori=2ToUBound(Arr1)Step22
IfArr1(i,j)<>""Then
Ifd.exists(Arr1(i,j))Then
n=d(Arr1(i,j))
Cells(n,col)=Cells(n,col)+Arr1(i+21,j+1)
Cells(n,col+32)=Cells(n,col+32)+Arr1(i+21,j+3)
EndIf
Else
ExitFor
EndIf
Next
EndIf
Next
.CloseFalse
EndWith
EndIf
myName=Dir
Loop
Application.ScreenUpdating=True
MsgBox"OK"
EndSub
31，多工作簿汇总(vbDirectory)
‘2012-9-23
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=924305&page=1#pid6330929
Subts()
DimmyPath$,subPath$,shcount&,wbAsObject
DimsubPaths()AsByte,br()
Dimi&,j&,k&,t!
t=Timer
Application.ScreenUpdating=False
myPath=ThisWorkbook.Path&"\绩效管理\"
subPath=Dir(myPath,vbDirectory)
DoWhilesubPath<>""
IfsubPath<>"."AndsubPath<>".."Then
k=k+1
ReDimPreservesubPaths(1Tok)
subPaths(k)=Val(Replace(subPath,"月份",""))
EndIf
subPath=Dir
Loop
Fori=1ToUBound(subPaths)-1
Forj=i+1ToUBound(subPaths)
IfsubPaths(i)>subPaths(j)Then
temp=subPaths(i):subPaths(i)=subPaths(j):subPaths(j)=temp
EndIf
Nextj
Nexti
Fori=1ToUBound(subPaths)
myPath1=myPath&subPaths(i)&"月份\"
myfile=Dir(myPath1&".xls")
DoWhilemyfile<>""
Setwb=GetObject(myPath1&myfile)
Withwb
Forj=1To.Sheets.Count
ar=.Sheets(j).[A3].Resize(.Sheets(j).Cells(Rows.Count,1).End(3).Row-2,13)
ReDimPreservebr(1To13,1ToUBound(ar)+myRows)
Form=myRows+1ToUBound(ar)+myRows
Forn=1To13
br(n,m)=ar(m-myRows,n)
Nextn
Nextm
myRows=myRows+UBound(ar)
Nextj
.CloseFalse
EndWith
myfile=Dir
Loop
Nexti
Sheet2.[A2:M65536].ClearContents
Sheet2.[A2].Resize(UBound(br,2),UBound(br))=Application.Transpose(br)
Application.ScreenUpdating=True
MsgBox"数据汇总完成!用时:"&Format(Timer-t,"0.00s")
EndSub
32，多工作簿汇总，先赋值给数组
‘2012-11-1
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=556649&page=11#pid6432836
SubMacro1()
DimMyPath$,MyName$,dAsObject,Arr,Brr(1To60000,1To22),i&,j&,m&,s$
Application.ScreenUpdating=False
Setd=CreateObject("scripting.dictionary")
MyPath=ThisWorkbook.Path&"\分表\"
MyName=Dir(MyPath&".xls")
DoWhileMyName<>""
WithGetObject(MyPath&MyName)
Arr=.Sheets(1).[a1].CurrentRegion
Fori=2ToUBound(Arr)
s=Arr(i,1)&","&Arr(i,6)&","&Arr(i,10)&","&Arr(i,12)
IfNotd.Exists(s)Then
d(s)=Arr(i,14)
m=m+1
Forj=1ToUBound(Arr,2)
Brr(m,j)=Arr(i,j)
Next
Brr(m,14)=d(s)
Else
d(s)=d(s)+Arr(i,14)
Forj=1Tom
s1=Brr(j,1)&","&Brr(j,6)&","&Brr(j,10)&","&Brr(j,12)
Ifs1=sThenBrr(j,14)=d(s):ExitFor
Next
EndIf
Next
.CloseFalse
EndWith
MyName=Dir
Loop
ActiveSheet.UsedRange.Offset(1).ClearContents
[a2].Resize(m,22)=Brr
Application.ScreenUpdating=True
EndSub
33，多工作表汇总，先赋值给数组
‘2013-2-3
‘查询按部门年汇总
Sublqxs()
DimArr,i&,ShtAsWorksheet,mm&,Brr
Dimd,k,t,j&,y&,d1,k1,t1,m&
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet4.Activate
[a4:g500].ClearContents
ForEachShtInSheets
IfLen(Sht.Name)=8AndInStr(Sht.Name,"工资")AndSht.Name<>Sheet5.NameThen
mm=mm+1
Arr=Sht.[a1].CurrentRegion
Ifmm=1Then
Fori=3ToUBound(Arr)
d(Arr(i,1))=d(Arr(i,1))&i&","
Next
k=d.keys
t=d.items
ReDimBrr(1Tod.Count,1To7)
Fori=0ToUBound(k)
t(i)=Left(t(i),Len(t(i))-1)
Brr(i+1,1)=k(i)
IfInStr(t(i),",")Then
aa=Split(t(i),",")
Forj=0ToUBound(aa)
Fory=3To8
Brr(i+1,y-1)=Brr(i+1,y-1)+Arr(aa(j),y)
Next
Next
Else
EndIf
Next
Else
Fori=3ToUBound(Arr)
d1(Arr(i,1))=d1(Arr(i,1))&i&","
Next
k1=d1.keys
t1=d1.items
Fori=0ToUBound(k1)
m=Application.Match(k1(i),k,0)
t1(i)=Left(t1(i),Len(t1(i))-1)
IfInStr(t1(i),",")Then
aa=Split(t1(i),",")
Forj=0ToUBound(aa)
Fory=3To8
Brr(m,y-1)=Brr(m,y-1)+Arr(aa(j),y)
Next
Next
Else
EndIf
Next
d1.RemoveAll
EndIf
EndIf
Next
[a4].Resize(UBound(Brr),7)=Brr
EndSub
34，多工作簿多工作表汇总(GetObject)
‘2016/6/29
‘http://club.excelhome.net/thread-1286450-1-1.html
Sublqxs()
DimmyPath$,myName$,shAsWorksheet
Dimi&,ad,nm,celAsRange
Application.ScreenUpdating=False
nm=Array("基本情况","存在问题","处理情况1","处理情况2","其他情况")
ad=Array("d9:t21","c7:x19","c6:ab18","d7:l19","a9:s9")
Fori=0ToUBound(nm)
Sheets(nm(i)).Range(ad(i)).ClearContents
Next
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls?")
DoWhilemyName<>""
IfInStr(myName,"汇总")=0Then
WithGetObject(myPath&myName)
Fori=0ToUBound(nm)
Setsh=.Sheets(nm(i))
WithSheets(nm(i))
ForEachcelInsh.Range(ad(i))
Ifcel.Value<>""Then
.Range(cel.Address)=.Range(cel.Address)+cel.Value
EndIf
Next
EndWith
Next
.CloseFalse
EndWith
EndIf
myName=Dir
Loop
Application.ScreenUpdating=True
EndSub
‘http://club.excelhome.net/thread-1113886-1-1.html
‘结果表.xlsm
‘2014-4-20
Sublqxs()
DimArr1,myPath$,myName$,shnm,nm
Dimj&,i&,d,y&,n&,Arr
Application.ScreenUpdating=False
Setd=CreateObject("Scripting.Dictionary")
Sheet1.Activate
Arr1=[a1].CurrentRegion
Fori=2ToUBound(Arr1)
IfArr1(i,3)="?"OrArr1(i,6)="?"OrArr1(i,9)="?"Then
d(Arr1(i,2))=i
EndIf
Next
nm=Array("3.xlsx","2.xlsx","1.xlsx")
shnm=Array("优先1","次优","次次优")
myPath=ThisWorkbook.Path&"\数据源\"
Fori=0ToUBound(nm)
myName=Dir(myPath&nm(i))
WithGetObject(myPath&myName)
Fory=0To2
Arr=.Sheets(shnm(y)).[a1].CurrentRegion
Forj=2ToUBound(Arr)
Ifd.exists(Arr(j,1))Then
n=d(Arr(j,1))
IfArr1(n,3)="?"ThenArr1(n,3)=Arr(j,3)
IfArr1(n,6)="?"ThenArr1(n,6)=Arr(j,4)
IfArr1(n,9)="?"ThenArr1(n,9)=Arr(j,5)
''exitfor
EndIf
Next
Next
.CloseFalse
EndWith
Next
[a1].CurrentRegion=Arr1
Application.ScreenUpdating=True
EndSub
‘2013-5-5
‘http://club.excelhome.net/thread-1014109-1-1.html
Sublqxs()
DimArr,myPath$,myName$,col%,m&,shAsWorksheet
Dimj&,i&,d,nm,n&,Brr(1To5000,1To20),c%,d1
Application.ScreenUpdating=False
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Sheet1.Activate
[a:h].ClearContents
myPath=ThisWorkbook.Path
aa=InStrRev(myPath,"\")
myPath=Left(myPath,aa)&"数据源\"
myName=Dir(myPath&".xlsx")
DoWhilemyName<>""
WithGetObject(myPath&myName)
ForEachshIn.Sheets
IfInStr(sh.Name,"数据源")Then
Arr=sh.[a1].CurrentRegion
Forj=1ToUBound(Arr,2)
IfArr(2,j)<>""Then
IfNotd.exists(Arr(2,j))Thenc=c+1:d(Arr(2,j))=c
col=d(Arr(2,j))
Fori=3ToUBound(Arr)
IfNotd1.exists(Arr(i,2))Then
m=m+1
d1(Arr(i,2))=m
Brr(m,col)=Arr(i,j)
Else
m=d1(Arr(i,2))
Brr(m,col)=Arr(i,j)
EndIf
Next
EndIf
Next
EndIf
Next
.CloseFalse
EndWith
myName=Dir
Loop
[a1].Resize(1,d.Count)=d.keys
[a2].Resize(m,d.Count)=Brr
Application.ScreenUpdating=True
EndSub
35，多工作簿多工作表汇总(searfile)
‘2015-11-1
‘’http://club.excelhome.net/forum.php?mod=viewthread&tid=1238947&pid=8435123&page=1&extra=#pid8435123
PublicBrr(),r&,s$
Sublqxs(s)
DimArr,myPath$
Dimi&,n&,aa,nm$,r1
Application.ScreenUpdating=False
[b:b].ClearContents
myPath=ThisWorkbook.Path&"\"
Callsearfile(myPath,".xlsx")
Fori=1ToUBound(Brr,2)
aa=Split(Brr(1,i),"\")
nm=aa(UBound(aa)-1)''文件夹名
WithGetObject(Brr(1,i)&Brr(2,i))
Setr1=.Sheets(1).[a:a].Find(s,,,2)
IfNotr1IsNothingThen
n=n+1
Cells(n,2)=nm&"-"&Brr(2,i)
EndIf
.CloseFalse
EndWith
Next
MsgBox"OK"
Application.ScreenUpdating=True
EndSub
‘2013-7-11
‘http://club.excelhome.net/thread-1034792-1-1.html
PublicBrr(),r&,ks,js
Sublqxs()
DimfpAsString,Arr1,i&,j&,r1,col%
DimshAsWorksheet,c%
Application.ScreenUpdating=False
fp=ThisWorkbook.Path&"\"
Callsearfile(fp,".xls")
ks=[b2].Value:js=[d2].Value
ForEachshInSheets
sh.Activate
Ifsh.Name="Health"Then
c=3
ElseIfsh.Name="Insurance"Then
c=4
ElseIfsh.Name="Grocery"Then
c=5
EndIf
Callyy(sh,c)
Next
Application.ScreenUpdating=True
EndSub
Subyy(sh,c)
[a3:z1000].ClearContents:n=3
Fori=ksTojs
n=n+1
Cells(n,1)=i
Next
col=1
Fori=1ToUBound(Brr,2)
IfInStr(Brr(2,i),"Table")Then
WithGetObject(Brr(1,i)&Brr(2,i))
Arr1=.Sheets(1).Range("A3").CurrentRegion
col=col+1
Cells(3,col)=Left(Brr(2,i),Len(Brr(2,i))-4)
Forj=3ToUBound(Arr1)
Setr1=[a:a].Find(Arr1(j,1),,,1)
IfNotr1IsNothingThen
Cells(r1.Row,col)=Arr1(j,c)
EndIf
Next
.CloseFalse
EndWith
EndIf
Next
EndSub
Subsearfile(fpAsString,fkeyAsString)
DimArr1()AsString,i1AsInteger,i2AsInteger,fm
IfRight(fp,1)<>"\"Thenfp=fp&"\"
IfLen(fkey)<1Thenfkey=".xls"''文件类型省略则仅搜索.xls文件
fm=Dir(fp,vbDirectory)
DoWhilefm<>""
Iffm<>"."Andfm<>".."Then
If(GetAttr(fp&fm)AndvbDirectory)=vbDirectoryThen
i1=i1+1
ReDimPreserveArr1(1Toi1)
Arr1(i1)=fp&fm
EndIf
IfRight(fm,Len(fkey))=fkeyThen
r=r+1
ReDimPreserveBrr(1To2,1Tor)
Brr(1,r)=fp
Brr(2,r)=fm
EndIf
EndIf
fm=Dir
Loop
Fori2=1Toi1
Callsearfile(Arr1(i2),fkey)
Next
EndSub
36，多工作簿搜索公式并复制工作簿
‘2013-9-23
‘http://club.excelhome.net/thread-1057806-1-1.html
Sub遍历文件()
DimFilePathAsString,FileNameAsString
DimSavePathAsString,FolderAsObject,Ar
Application.ScreenUpdating=False
Application.ShowWindowsInTaskbar=False
Application.DisplayAlerts=False
WithCreateObject("shell.application")
SetFolder=.BrowseForFolder(0,"请选择文件所在目录",0,"")
IfFolderIsNothingThenExitSub
FilePath=Folder.Items.Item.Path&"\"
SetFolder=.BrowseForFolder(0,"请选择要复制到的目录",0,"")
IfFolderIsNothingThenExitSub
SavePath=Folder.Items.Item.Path&"\"
EndWith
SetFolder=Nothing
bb=InputBox("输入搜索条件：","","ab376")
Ifbb=""ThenMsgBox"输入的格式有误":ExitSub
FileName=Dir(FilePath&".xls")
DoUntilFileName=""
IfFileName<>ThisWorkbook.NameThen''判断是不是本工作簿
WithWorkbooks.Open(FilePath&FileName,False,True)''打开文件进行判断
Setwb=ActiveWorkbook
Sheet1.Activate
ActiveWindow.DisplayFormulas=True‘单元格显示公式
IfInStr(Sheet1.[a1].Text,UCase(bb))ThenFileCopyFilePath&FileName,SavePath&FileName
.CloseFalse
EndWith
EndIf
FileName=Dir
Loop
IfMsgBox("搜索完成，是否打开文件？",vbExclamation+vbYesNo,"完成！")=vbYesThenShell"explorer"&SavePath,vbNormalFocus
Application.ScreenUpdating=True
Application.ShowWindowsInTaskbar=True
Application.DisplayAlerts=True
EndSub
37，多文件夹多工作簿多工作表汇总(searfile)
‘2014-8-29
‘http://club.excelhome.net/thread-1148457-1-1.html
PublicBrr(),r&
Sublqxs()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimi&,n&,d,k,t,aa,nm$,j&,b
Application.ScreenUpdating=False
Setd=CreateObject("Scripting.Dictionary")
myPath=ThisWorkbook.Path&"\原始文件\"
Callsearfile(myPath,".xlsx")
Fori=1ToUBound(Brr,2)
aa=Split(Brr(1,i),"\")
nm=aa(UBound(aa)-1)
d(nm)=d(nm)&Brr(1,i)&"|"&Brr(2,i)&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
t(i)=Left(t(i),Len(t(i))-1)
IfInStr(t(i),",")Then
aa=Split(t(i),",")
Application.SheetsInNewWorkbook=UBound(aa)+1
Workbooks.Add‘新工作簿的表格数量
Setwb=ActiveWorkbook:n=0
Forj=0ToUBound(aa)
b=Split(aa(j),"|")
WithGetObject(b(0)&b(1))
ForEachshIn.Sheets
Arr=sh.Range("a1").CurrentRegion
n=n+1
Withwb.Sheets(n)
.[a1].Resize(UBound(Arr),UBound(Arr,2))=Arr
.Name=sh.Name
EndWith
Next
.CloseFalse
EndWith
Next
Else
Application.SheetsInNewWorkbook=1
Workbooks.Add
Setwb=ActiveWorkbook:n=0
b=Split(t(i),"|")
WithGetObject(b(0)&b(1))
ForEachshIn.Sheets
Arr=sh.Range("a1").CurrentRegion
n=n+1
Withwb.Sheets(n)
.[a1].Resize(UBound(Arr),UBound(Arr,2))=Arr
.Name=sh.Name
EndWith
Next
.CloseFalse
EndWith
EndIf
wb.SaveAsThisWorkbook.Path&"\"&k(i)&".xlsx"
wb.CloseFalse
Next
Application.ScreenUpdating=True
EndSub
‘2014-12-26
‘http://club.excelhome.net/thread-1175063-1-1.html
Sublqxs()
DimArr,myPath$,myName$,d,k,t
DimwbAsWorkbook,nm,aa,i&,j&
Setd=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
myPath=ThisWorkbook.Path&"\明细\"
Callsearfile(myPath,".xls")
Fori=1ToUBound(Brr,2)
nm=Split(Brr(2,i),"（")
d(nm(0))=d(nm(0))&Replace(nm(1),"）.xls","")&","
Next
k=d.keys:t=d.items
Fori=0ToUBound(k)
t(i)=Left(t(i),Len(t(i))-1)
IfInStr(t(i),",")Then
aa=Split(t(i),",")
Application.SheetsInNewWorkbook=UBound(aa)+1‘新增加工作簿的工作表的个数
Workbooks.Add
Setwb=ActiveWorkbook
Forj=0ToUBound(aa)
wb.Sheets(j+1).Name=aa(j)
WithGetObject(myPath&k(i)&"（"&aa(j)&"）.xls")
Arr=.Sheets(1).UsedRange
.CloseFalse
EndWith
wb.Sheets(j+1).[a1].Resize(UBound(Arr),UBound(Arr,2))=Arr
Next
Else
Workbooks.Add
Setwb=ActiveWorkbook
wb.Sheets(1).Name=t(i)
WithGetObject(myPath&k(i)&"（"&t(i)&"）.xls")
Arr=.Sheets(1).UsedRange
.CloseFalse
EndWith
wb.Sheets(1).[a1].Resize(UBound(Arr),UBound(Arr,2))=Arr
EndIf
wb.SaveAsThisWorkbook.Path&"\合并效果\"&k(i)&"1.xls"
wb.Close
Next
Application.ScreenUpdating=True
EndSub
38，多工作簿多工作表汇总
‘2015/4/25
‘
Sublqxs()
DimArr,myPath$,myName$,wbAsWorkbook,shAsWorksheet
Dimfunm$,i&,j&,d,d1,nm$,x$,y$,Brr,Myc%
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
Setwb=ThisWorkbook
funm=wb.Name
nm="1,2,3,4,5,6,7,8,9,10,"
ForEachshInSheets
IfInStr(nm,sh.Name&",")Then
sh.[b2:z500].ClearContents
EndIf
Next
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xlsx")
DoWhilemyName<>""
IfmyName<>funmThen
WithGetObject(myPath&myName)
ForEachshIn.Sheets
IfInStr(nm,sh.Name&",")Then
Arr=sh.Range("a1").CurrentRegion
Fori=2ToUBound(Arr)
Forj=2ToUBound(Arr,2)
x=Arr(i,1):y=Arr(1,j)
Ifd.exists(x)=FalseThenSetd(x)=CreateObject("Scripting.Dictionary")
d(x)(y)=Arr(i,j)
Next
Next
Withwb.Sheets(sh.Name)
Brr=.Range("a1").CurrentRegion
Forj=2ToUBound(Brr,2)
d1(Brr(1,j))=""
Next
Forj=2ToUBound(Arr,2)
IfNotd1.exists(Arr(1,j))Then
Myc=.[iv1].End(xlToLeft).Column+1
.Cells(1,Myc)=Arr(1,j)
d1(Arr(1,j))=""
EndIf
Next
Brr=.Range("a1").CurrentRegion
Fori=2ToUBound(Brr)
Forj=2ToUBound(Brr,2)
x=Brr(i,1):y=Brr(1,j)
Ifd.exists(x)Then
Ifd(x).exists(y)Then
Brr(i,j)=Brr(i,j)+d(x)(y)
EndIf
EndIf
Next
Next
.Range("a1").CurrentRegion=Brr
EndWith
d1.RemoveAll
EndIf
Next
.CloseFalse
EndWith
d.RemoveAll
EndIf
myName=Dir
Loop
MsgBox"OK"
Application.ScreenUpdating=True
EndSub
39，提取指定文件夹内的所有文件名
‘http://www.excelpx.com/thread-425053-1-1.html
Subtest()''提取指定文件夹内的所有文件名
''含所有子文件夹内的文件
DimFsoAsObject,arrf$(),mf&
SetFso=CreateObject("Scripting.FileSystemObject")
CallGetFiles(CreateObject("Shell.Application").BrowseForFolder(0,"请选择文件夹",0,"").Self.Path,Fso,arrf,mf)
Sheet2.[b2].Resize(mf)=Application.Transpose(arrf)
SetFso=Nothing
EndSub
PrivateSubGetFiles(ByValsPath$,ByRefFsoAsObject,ByRefarrf$(),ByRefmf&)
DimFolderAsObject
DimSubFolderAsObject
DimFileAsObject
SetFolder=Fso.GetFolder(sPath)
ForEachFileInFolder.Files
mf=mf+1
ReDimPreservearrf(1Tomf)
arrf(mf)=File.Path''&File.Name
Next
ForEachSubFolderInFolder.SubFolders
CallGetFiles(SubFolder.Path,Fso,arrf,mf)
Next
SetFolder=Nothing
SetFile=Nothing
EndSub
40，提取指定文件夹（包括子文件夹）内的所有文件名
Publick,kxm,txm,dxm
Submain()
DimfpAsString,Arr,i&,Myr&
DimShtAsWorksheet,shAsWorksheet,dic
Setdic=CreateObject("Scripting.Dictionary")
Setdxm=CreateObject("Scripting.Dictionary")
Application.ScreenUpdating=False
fp=ThisWorkbook.Path&"\"
Callsearfile(fp,".jpg")
SetSht=ActiveSheet
Myr=Sheet2.[d65536].End(xlUp).Row
Arr=Sheet2.Range("d1:d"&Myr)
Fori=2ToUBound(Arr)
dic(Arr(i,1))=""
Next
k=dic.keys
Application.ScreenUpdating=True
EndSub
Subsearfile(fpAsString,fkeyAsString)
DimArr1()AsString,i1AsInteger,i2AsInteger,fm,aa,xm$,nm$
IfRight(fp,1)<>"\"Thenfp=fp&"\"
IfLen(fkey)<1Thenfkey=".xls"
fm=Dir(fp,vbDirectory)
DoWhilefm<>""
Iffm<>"."Andfm<>".."Then
If(GetAttr(fp&fm)AndvbDirectory)=vbDirectoryThen
i1=i1+1
ReDimPreserveArr1(1Toi1)
Arr1(i1)=fp&fm
EndIf
IfRight(fm,4)=fkeyThen
aa=Split(fp,"\")
xm=aa(UBound(aa)-1)
nm=Split(fm,".")(0)
dxm(xm)=dxm(xm)&nm&","
Else
dxm(fm)=""
EndIf
EndIf
fm=Dir
Loop
Fori2=1Toi1
Callsearfile(Arr1(i2),fkey)
Next
kxm=dxm.keys:txm=dxm.items
EndSub
41，多工作簿汇总，分表名为表头(字典套字典)
‘2017-6-5
‘http://club.excelhome.net/thread-1349963-1-1.html
Sublqxs()
DimArr,myPath$,myName$,Arr1,i&,j&,x$,y$
Dimd,d1,bt,k,t,k1,aa,s$
Dimbb,m&,col%
Setd=CreateObject("Scripting.Dictionary")
Setd1=CreateObject("Scripting.Dictionary")
ActiveWindow.DisplayZeros=False
Application.DisplayAlerts=False
Application.ScreenUpdating=False
Sheet1.Activate
bt=Array("工作时间","加班时间")
[a3:e5000].Clear
[f1:bz5002].Clear
Cells.Font.Size=11
myPath=ThisWorkbook.Path&"\"
myName=Dir(myPath&".xls")
DoWhilemyName<>""
IfInStr(myName,"汇总")=0Then
WithGetObject(myPath&myName)
Arr1=.Sheets(1).[a1].CurrentRegion
Fori=3ToUBound(Arr1)
x=Arr1(i,2):y=Split(myName,".")(0)
Ifd.exists(x)=FalseThenSetd(x)=CreateObject("Scripting.Dictionary")
d(x)(y)=d(x)(y)&Arr1(i,6)&"|"&Arr1(i,6)
d1(y)=""
Next
.CloseFalse
EndWith
EndIf
myName=Dir
Loop
k=d.keys:t=d.items:k1=d1.keys
Fori=0ToUBound(k1)+1
Ifi<>UBound(k1)+1Thens=k1(i)Elses="合计"
WithCells(1,2i+6).Resize(1,2)
.Value=s
.Merge
.HorizontalAlignment=xlCenter
.VerticalAlignment=xlCenter
EndWith
Cells(2,2i+6).Resize(1,2)=bt
Next
col=2d1.Count+6
[b3].Resize(d.Count)=Application.Transpose(k)
[a3]=1:[a4]=2:[a3:a4].AutoFill[a3].Resize(d.Count)
m=d.Count+3
Cells(m,2)="合计"
Fori=0ToUBound(k)
Forj=0ToUBound(k1)
Ifd(k(i)).exists(k1(j))Then
bb=d(k(i))(k1(j))
aa=Split(bb,"|")
Cells(i+3,2j+6)=Val(aa(0))
Cells(i+3,2j+7)=Val(aa(1))
Cells(i+3,col)=Cells(i+3,col)+Val(aa(0))
Cells(i+3,col+1)=Cells(i+3,col+1)+Val(aa(1))
EndIf
Next
Next
Cells(m,6).Formula="=sum(r3c:r[-1]c)"
Cells(m,6).AutoFillCells(m,6).Resize(1,col-4)
[a1].CurrentRegion.Borders.LineStyle=1
Application.DisplayAlerts=True
Application.ScreenUpdating=True
EndSub
|
|
