ExcelVBA多工作簿多工作表汇总情况实例集锦文档格式.docx
《ExcelVBA多工作簿多工作表汇总情况实例集锦文档格式.docx》由会员分享,可在线阅读,更多相关《ExcelVBA多工作簿多工作表汇总情况实例集锦文档格式.docx(97页珍藏版)》请在冰豆网上搜索。
![ExcelVBA多工作簿多工作表汇总情况实例集锦文档格式.docx](https://file1.bdocx.com/fileroot1/2023-1/23/9811a8b8-bd9f-41f3-a7fb-0aed16f80ec3/9811a8b8-bd9f-41f3-a7fb-0aed16f80ec31.gif)
).ConsolidateRangeArray,xlSum,True,True
[a1].Value="
某某"
EndSub
Subsumdemo()
DimarrAsVariant
arr=Array("
一月!
R1C1:
R8C5"
"
二月!
R5C4"
三月!
R9C6"
WithWorksheets("
).Range("
.Consolidatearr,xlSum,True,True
.Value="
EndWith
2,多工作簿汇总〔Consolidate〕
‘多工作簿汇总
DimbkAsWorkbook
ForEachbkInWorkbooks'
在所有工作簿中循环
IfNotbkIsThisWorkbookThen'
非代码所在工作簿
Setsht=bk.Worksheets
(1)'
引用工作簿的第一个工作表
["
bk.Name&
]"
EndIf
Worksheets
(1).Range("
).Consolidate_
RangeArray,xlSum,True,True
3,多工作簿汇总〔FileSearch〕
‘
Subpldrwb0531()
导入指定文件的数据
DimmyFsAsFileSearch
DimmyPathAsString,Filename$
DimiAsLong,nAsLong
DimSht1AsWorksheet,shAsWorksheet
Dimaa,nm$,nm1$,m,arr,r1,col1%
Application.ScreenUpdating=False
SetSht1=ActiveSheet
WithmyFs
.NewSearch
.LookIn=myPath
.FileType=msoFileTypeNoteItem
.Filename="
*.xls"
If.Execute(SortBy:
=msoSortByFileName)>
0Then
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<
汇总表"
Workbooks.Openmyfile(i)
DimwbAsWorkbook
Setwb=ActiveWorkbook
m=[a65536].End(xlUp).Row
arr=Range(Cells(3,3),Cells(m,3))
col1=col1+1
Cells(2,col1)=nm'
自动获取文件名
Cells(3,col1).Resize(UBound(arr),1)=arr
wb.Closesavechanges:
=False
Setwb=Nothing
Else
MsgBox"
该文件夹里没有任何文件"
[a1].Select
SetmyFs=Nothing
Application.ScreenUpdating=True
‘根据上例增加了在一个工作簿中可选择多个工作表进展汇总,运用了文本框多项选择功能
Publicar,ar1,nm$
导入指定文件的数据〔默认工作表1的数据〕
直接从C列依次导入
Dimaa,nm1$,m,arr,r1,col1%
OnErrorResumeNext
col1=2
ForEachshInSheets
s=s&
sh.Name&
"
s=Left(s,Len(s)-1)
ar=Split(s,"
Forj=0ToUBound(ar1)
IfErr.Number=9ThenGoTo100
Setsh=wb.Sheets(ar1(j))
m=sh.[a65536].End(xlUp).Row
arr=Range(Cells(3,3),Cells(m,3))
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:
Setwb=Nothing
s="
IfVarType(ar1)=8200ThenErasear1
PrivateSubmandButton1_Click()
Fori=0ToListBox1.ListCount-1
IfListBox1.Selected(i)=TrueThen
ListBox1.List(i)&
Nexti
Ifs<
s=Left(s,Len(s)-1)
ar1=Split(s,"
MsgBox"
你选择了"
s
UnloadUserForm1
Else
mg=MsgBox("
你没有选择任何工作表!
需要重新选择吗?
vbYesNo,"
提示"
Ifmg=6Then
UnloadUserForm1
EndIf
PrivateSubmandButton2_Click()
PrivateSubUserForm_Initialize()
.List=ar‘文本框赋值
.ListStyle=1‘文本前加选择小方框
.MultiSelect=1‘设置可多项选择
EndWith
Me.Label1.Caption=Me.Label1.Caption&
nm
4,多工作表汇总〔字典、数组〕
Subdbhz()
多表汇总
DimSht1AsWorksheet,Sht2AsWorksheet,ShtAsWorksheet
Dimd,k,t,Myr&
Arr,x
Application.DisplayAlerts=False
Setd=CreateObject("
Scripting.Dictionary"
ForEachShtInSheets‘删除同名的表格,获得要增加的汇总表格不重复名字
IfInStr(Sht.Name,"
-"
)>
0ThenSht.Delete:
GoTo100
nm=Mid(Sht.[a3],7)
d(nm)="
NextSht
Application.DisplayAlerts=True
Fori=0ToUBound(k)
Sheets.Addafter:
=Sheets(Sheets.Count)
SetSht1=ActiveSheet
Sht1.Name=Replace(k(i),"
/"
)‘增加汇总表,把名字中的〞/〞〔不能用作表名的〕改为〞-“
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("
Fori=1ToUBound(Arr)
x=Arr(i,1)
IfNotd.exists(x)Then
d.Addx,Arr(i,5)
d(x)=d(x)+Arr(i,5)
SetSht2=Sheets(nm)
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)
Cells(myr2,1).Resize(UBound(k)+1,1)=Application.Transpose(k)
Cells(myr2,2).Resize(UBound(t)+1,1)=Application.Transpose(t)
Erasek
Eraset
Setd=Nothing
5,多工作簿提取指定数据〔FileSearch〕
‘2011-8-31
SubGetData()
DimBrrbz(1To200,1To19),Brrgr(1To500,1To23)
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,wbnm$
Dimi&
n&
mm&
aa$,nm1$,j&
DimSht1AsWorksheet,shAsWorksheet,wb1AsWorkbook
Setwb1=ThisWorkbook
wbnm=Left(wb1.Name,Len(wb1.Name)-4)
Sht1.[a2:
w200]="
aa=Left(Sht1.Name,2)
myPath=ThisWorkbook.Path&
WithmyFs
.SearchSubFolders=True
nm1=Split(Mid(Filename,InStrRev(Filename,"
)+1),"
."
)(0)
Ifnm1=wbnmThenGoTo200
IfInStr(sh.Name,aa)Then
Ifaa="
班子"
mm=mm+1
Brrbz(mm,1)=[b2].Value
Forj=2To18Step2
Ifj<
10Then
Brrbz(mm,j)=Cells(j/2+34,11).Value
Brrbz(mm,j)=Cells(j/2+34,9).Value
If[b2]="
ThenGoTo50
Brrgr(mm,1)=[b2].Value
Brrgr(mm,2)=[e38].Value
Brrgr(mm,3)=[i38].Value
Forj=4To18Step2
12Then
Brrgr(mm,j)=Cells(j/2+38,8).Value
Brrgr(mm,j)=Cells(j/2+38,7).Value
Forj=20To23
Brrgr(mm,j)=Cells(j+28,8).Value
50:
200:
Ifaa="
[a2].Resize(mm,19)=Brrbz
[a2].Resize(mm,23)=Brrgr
[a1].Select
SetmyFs=Nothing
‘2011-7-15
Subpldrsj()'
批量导入指定文件的数据
DimmyFsAsFileSearch,myfile,Brr
DimmyPath$,Filename$,nm2$
Dimi&
j&
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="
.SearchSubFolders=True
If.Execute(SortBy:
0Then
n=.FoundFiles.Count
ReDimBrr(1Ton,1To2)
ReDimmyfile(1Ton)AsString
Fori=1Ton
myfile(i)=.FoundFiles(i)
Filename=myfile(i)
)
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
EndIf
EndWith
Sht1.Select
[a3].Resize(UBound(Brr),2)=Brr
SetmyFs=NothingApplication.ScreenUpdating=TrueEndSub
Subpldrsj0707()
批量导入指定文件的数据
DimmyFsAsFileSearch,myfile
DimmyPathAsString,Filename$,ma&
mc&
DimiAsLong,nAsLong,nn&
aa$,nm$,nm1$
Application.ScreenUpdating=False
SetSht1=ActiveSheet:
nn=5
Sht1.[b5:
e27]="
myPath=ThisWorkbook.Path&
\data"
‘指定的子文件夹内搜索
.LookIn