Ecel VBA多工作簿多工作表汇总实例集锦.docx
《Ecel VBA多工作簿多工作表汇总实例集锦.docx》由会员分享，可在线阅读，更多相关《Ecel VBA多工作簿多工作表汇总实例集锦.docx（142页珍藏版）》请在冰豆网上搜索。
EcelVBA多工作簿多工作表汇总实例集锦
１,多工作表汇总（Cｏnsoliｄａte）
‘
‘两种写法都要求地址用R1C1形式，各个表格得数据布置有规定。
ＳubCｏnsｏlｉdatｅＷｏrkboｏｋ（）
ＤiｍＲangeArray（）ＡsStriｎg
Dim bkAsWorkshｅet
ＤimｓhtAｓWｏrkｓheｅt
DimWｂCountＡｓInｔeｇeｒ
Set bｋ = Sheeｔｓ（"汇总＂）
WｂCｏｕnt＝Sｈｅetｓ、Couｎｔ
ReDimRangｅArｒａy（１ToWbCoｕnt—１）
Fｏr Eａｃhsht InSheets
Iｆｓht、Naｍe<＞”汇总"Ｔhｅn
i =ｉ ＋ 1
RaｎｇeAｒray（i）=”'”＆sht、Nａme＆"＇！
”＆ _
ｓht、Ｒａｎge（”Ａ１"）、CurrｅntRｅgiｏn、Ａddrｅsｓ（ＲeferenceStylｅ:
=ｘlR1Ｃ1）
EndIf
Ｎｅｘｔ
ｂｋ、Range（＂A1"）、ConｓolidaｔｅRangｅAｒrａy，xlSum,Tｒue，Tｒue
［a1]、Ｖalｕe="姓名＂
EｎdSub
Sｕｂｓumdeｍo（）
DimaｒrAsＶarｉａｎt
aｒr =Ａrrａy（"一月！
R1C１:
R8C5","二月!
R1C1：
R5C4"，”三月！
R1C1:
Ｒ９C6"）
WｉthWorｋsheeｔs（”汇总"）、Raｎge（"A1”）
、Consolidate arr，xlSum，Ｔrｕe,Tｒue
、Ｖaｌue=＂姓名"
EndWiｔh
EndSuｂ
２,多工作簿汇总（Consoliｄaｔe）
‘多工作簿汇总
SubCｏnsｏliｄatｅWorｋbｏｏｋ（）
DimＲａngeArray（）ＡsString
Ｄimbｋ ＡsWｏrkbｏｏk
Dimsht ＡｓWorksｈeet
DimWbCｏunt AsＩnｔegｅr
WbCouｎt=Workboｏks、Count
RｅＤimRａngeＡrｒay（1ToWｂCount-1）
ForEacｈbkIn Woｒｋｂooks ’在所有工作簿中循环
ＩｆＮotbkＩｓＴｈiｓＷoｒkｂｏｏkThen＇非代码所在工作簿
Ｓetsht= ｂk、Wｏｒkshｅets
（1）’引用工作簿得第一个工作表
i=i+1
RａｎｇeＡrｒay（i） ＝"'[＂&bk、Nａme＆”]＂&ｓｈt、Namｅ ＆ ”＇！
＂＆_
ｓht、Ranｇe（”A1”）、CｕrrｅntRｅgiｏn、Ａddreｓs（ReferｅnｃeStｙｌe：
=ｘlＲ1C1）
EndIf
Next
Worｋsｈeｅtｓ（１）、Range（”Ａ1”）、Cｏnsoliｄate_
ＲaｎｇeArｒay，ｘlＳｕm,True，Truｅ
End Ｓuｂ
3，多工作簿汇总（）
‘2007－1—1、html＃＃＃
‘help\汇总表、xｌｓ
Subpldrwb0５31（）
'汇总表、ｘlｓ
’导入指定文件得数据
ＤｉmmyFsAs
Ｄim ｍyPatｈAsString,＄
ＤiｍｉAsLｏng，nAsLｏng
ＤimＳｈt1 ＡsＷorksheｅｔ，shAs Ｗｏrｋsｈeet
Dimaa,nｍ＄,nm1＄,ｍ，aｒr,ｒ1,col1％
Apｐlicatｉon、SｃreenUｐdating=Ｆalse
SeｔSht1=ActivｅSｈeet
Set myFｓ＝Aｐplicatioｎ、
myPatｈ=TｈiｓWorkbook、Pａth
WiｔhｍyFs
、ＮeｗSｅarch
、LookＩn=myPaｔh
、=mso
、="＊、xls"
Ｉｆ、Ｅｘeｃute（ＳorｔBｙ：
=msoSｏrｔBy）＞ 0Then
n=、Found
ｃol１=2
RｅDｉmmｙfile（１Ｔon）ＡsSｔriｎg
Ｆｏｒ i=1Ｔo ｎ
myfiｌe（ｉ）=、FoundFｉｌes（i）
=myｆile（i）
aａ ＝InStrRev（，"\＂）
nm＝ Rigｈt（，Leｎ（）-ａａ）
nm1= Ｌefｔ（nｍ, Ｌeｎ（nm）-4）
Ifnm１ 〈〉”汇总表"Thｅn
Workbooｋs、Openmyｆile（i）
DimｗbＡsWorkbook
Sｅtwb = ActivｅWｏｒｋｂoｏk
m=[ａ65536]、Enｄ（xlUp）、Row
arr = Ranｇｅ（Ｃeｌls（３,3），Cｅlls（m,３））
Sht1、Acｔivａte
col1 =col1+1
Cells（2，ｃol1）=nm'自动获取文件名
Celｌs（3,ｃoｌ１）、Ｒeｓiｚe（UBound（ａrr），1）＝ａrｒ
wb、Cｌosesａvechaｎgeｓ:
=False
Ｓeｔwｂ＝Noｔｈinｇ
EｎdＩｆ
Next
Ｅlｓｅ
MｓgBｏx”该文件夹里没有任何文件＂
EndIf
ＥｎdWｉth
[a1］、Selｅｃt
Seｔ myＦｓ=Nothｉnｇ
Apｐliｃａtioｎ、ＳｃｒeeｎＵpdａｔiｎg= Trｕe
EndSｕb
‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总,运用了文本框多选功能
Public ａr，aｒ1，nｍ＄
Ｓubpldｒｗb0531（）
'汇总表、xls
＇导入指定文件得数据（默认工作表1得数据）
'直接从C列依次导入
DｉmｍｙFｓAs
Diｍ ｍyPathAsStrｉng, $
Dim ｉAsLonｇ,n AsLong
Dim Sht１AｓWorｋsheeｔ, ｓhAｓ Workshｅｅt
Dｉｍaａ，ｎm1$， m,aｒr,r1， col1％
Aｐｐｌicatiｏn、ScreeｎUpdaｔｉng =Fａlse
OnEｒｒｏrReｓuｍeNeｘt
SetＳｈt１=ＡctiveSheet
SｅtmyFs＝Aｐｐｌiｃａtion、
mｙPaｔｈ=ThｉsWoｒkbook、Path
WithｍyＦｓ
、NｅwSeａrch
、LｏｏｋIn =myPath
、=mso
、 =”＊、xｌs”
Ｉf、Execute（SｏrtＢｙ：
=mｓoSorｔＢy）>0Tｈeｎ
n= 、Foｕnｄ
ｃｏl１= 2
ＲｅDiｍmyfile（1Ton） AsString
Fori=1Tｏn
myfｉle（i）= 、FｏuｎdFilｅｓ（i）
=ｍyfile（ｉ）
aａ＝InStrReｖ（，”\"）
nm=Right（，Lｅn（）-aa）
nm1=Ｌeft（nｍ，Ｌen（nm） －4）
Ifnｍ1〈〉”汇总表”Tｈen
Wｏrkｂooks、Ｏpenmyfile（i）
DｉmwbＡｓ Wｏrkｂooｋ
Ｓeｔwb= ActiveＷorｋｂoｏk
ForEachshＩnＳheets
s=s ＆sｈ、Nａme&＂,”
Nｅxt
ｓ=Ｌeft（s,Len（s）- １）
ar = Splｉt（s，"，”）
ＵserForm1、Show
Forｊ＝０ToＵBｏunｄ（ar1）
ＩfＥrr、Ｎumｂer =9Tｈｅn ＧoＴo10０
Set sh＝ wb、Sheets（ａr1（j））
sh、Ａcｔivａte
ｍ=sh、［ａ655３6]、End（xlUp）、Rｏw
arｒ=Raｎgｅ（Cellｓ（3,3），Ｃells（m，3））
Ｓht1、Actｉvａtｅ
ｃol１=col1+1
Cｅllｓ（2,coｌ1）＝ sh、[a1]
Cells（3，col1）、FｏrmuｌａR1C1＝”＝［"＆ nm＆"]"＆ａr１（j）&"！
ＲC3” ‘显示引用得工作簿工作表及单元格地址
Cells（3,col1）。
AutoFｉll Range（Ｃｅlｌs（3, col1）, Cells（UBoｕnd（arｒ） +２，col1））
‘Cｅlls（3，col１）、Rｅsize（UBound（arr）， 1） ＝ ａrr
Neｘtｊ
10０:
wb、Cｌoｓesａvechanｇeｓ:
=Fａlse
Seｔwb =Ｎotｈing
ｓ=""
ＩfVarType（ar１）= 8２00ThenErａｓear1
EnｄIf
Nexｔ
Ｅｌse
MsgBox”该文件夹里没有任何文件"
EnｄIｆ
End Wｉth
［ａ１］、Sｅｌecｔ
ＳeｔmyＦs =Nothｉｎg
Appliｃatiｏn、ＳｃreｅnUpdａting＝ Ｔrue
ＥndSub
PriｖateSｕｂmanｄBｕttoｎ1_Ｃｌick（）
Fori= 0Ｔｏ LisｔBｏｘ１、LｉstＣoｕnt—1
IfListBox1、Selecｔed（i）＝True Thｅn
s= s＆ ListBｏx1、Lｉst（ｉ）&”，"
EndIf
Neｘti
Iｆs<>””Then
s=Lｅfｔ（s,Lｅn（s）－1）
ａr1= Split（ｓ， ”，”）
MｓgBox”您选择了"＆ｓ
UnloadUsｅrForm1
Else
mｇ＝ MｓｇBox（”您没有选择任何工作表！
需要重新选择吗?
", vbYｅｓNo,”提示"）
Ifmg=6Ｔｈen
Elｓｅ
UnloadUｓerＦoｒｍ１
EndIf
End If
ＥndSub
ＰrｉvateSubmanｄButton2_Click（）
Ｕnloaｄ UserForm1
EnｄSub
PｒｉvaｔeSub ＵｓerForm_Initialize（）
WitｈMｅ、ListＢox1
、List=aｒ‘文本框赋值
、ListStｙle＝1 ‘文本前加选择小方框
、MultｉSeｌecｔ=1 ‘设置可多选
EndＷith
Me、Label1、Capｔioｎ =Me、Ｌabel1、Captｉon&nｍ
Eｎd Ｓub
４,多工作表汇总（字典、数组）
‘
‘Dａｔａ多表汇总06２３、ｘls
Ｓubdｂｈｚ（）
'多表汇总
Dim Sht1AsWorｋｓｈeｅt，Ｓht2 AsＷoｒksheeｔ,Ｓht AsＷoｒkshｅet
Diｍd，k,t，Ｍyr＆， Ａrr， ｘ
Applicａtion、ＳcｒeenUpｄating =Ｆａlse
Aｐplｉcaｔｉoｎ、ＤｉｓｐlａyAlerts= Falｓe
Sｅtｄ =CｒeａtｅObｊect（”Ｓｃripting、Ｄictｉoｎary”）
ＦorＥachShｔIｎShｅeｔs ‘删除同名得表格，获得要增加得汇总表格不重复名字
IfIｎStr（Sht、Nａme,"-"） 〉0ThenＳht、Delete：
GｏＴｏ１0０
nｍ=Ｍid（Sht、[a３],7）
d（nｍ）=""
１０0：
Ｎｅｘt Ｓhｔ
Ａｐplicatioｎ、ＤiｓplayAｌｅrts＝Tｒue
k= d、keｙs
Fｏri=０ToUBｏund（ｋ）
Ｓhｅets、Aｄdafter:
=Sheeｔs（Sheets、Counｔ）
SｅtＳｈt1 =ActiｖeShｅeｔ
Ｓht1、Namｅ=Rｅpｌace（k（i）, "/”， ＂-”） ‘增加汇总表，把名字中得”/”（不能用作表名得）改为”—“
Ｎexti
Ｅraｓek
Setd= Nothing
FoｒEacｈ SｈtＩnＳheｅts
Wｉth Ｓht
、Actｉｖate
Iｆ InStr（、Name，"－"） = ０ Tｈen
nm=Replａcｅ（Mｉd（、[a3］, 7）， ”/",＂-"）
Myｒ＝、［ｈ65５３6]、Eｎd（xlUｐ）、Rｏw
Ａrr =、Ranｇｅ（”d10：
h"&Ｍyr）
Sｅtd=ＣrｅateObjeｃt（”Sｃｒipting、Diｃｔionary"）
Ｆori= 1 ToＵBounｄ（Aｒr）
x =Ａrr（ｉ，１）
IfNｏｔd、ｅxisｔs（x） Thｅn
d、Ａｄdx,Ａrr（i，5）
Elｓe
d（x）= d（x）+Ａrr（i，5）
Ｅnd If
Ｎeｘｔ
k=d、ｋeyｓ
t=d、iｔｅｍｓ
Set Sht２=Sheｅts（nｍ）
Ｓht2、Actiｖａｔe
myr2 = [a65５36］、End（ｘlＵｐ）、Ｒｏw+1
If myｒ2＜ 9 Ｔheｎ
Ｃelｌs（9，1）、Resｉｚe（1， 2） ＝Aｒraｙ（＂PartNo、"，”TＴＬQty＂）
Cellｓ（10,1）、Rｅsizｅ（UBoｕｎd（k）+1,１）=Applicatioｎ、Ｔｒansposｅ（ｋ）
Cellｓ（10,2）、Rｅｓize（UBｏund（t）+ １，1）=Ａｐplｉcaｔion、Trａnspｏse（t）
Elsｅ
Cｅlｌs（myr2,１）、Resiｚe（UBｏｕnd（k）+1，1） =Applｉcatiｏn、Tranｓｐｏsｅ（k）
Celｌs（myr2，２）、Ｒeｓｉｚe（UBoｕnｄ（t）＋ 1, 1）= Applｉcａtｉｏｎ、Tｒanspｏse（ｔ）
EndIf
Eｒasek
Ｅrａse ｔ
Sｅｔd=Ｎothing
ＥndIf
Eｎd Wiｔh
NextShｔ
Appｌｉcatiｏn、ScｒeenUpdatinｇ= True
End Sub
5，多工作簿提取指定数据（）
‘201１—8-31
‘９188-1—1、htｍl
ＳuｂGetDaｔa（）
ＤｉmBrrbｚ（1To２00, 1Tｏ 19）,Bｒrgr（1Ｔo500， 1To23）
Ｄim ｍyFs Aｓ ，myｍyPathAs Ｓtring， ＄， ｗbnm＄
Dim i&, n＆,ｍｍ&， aa$,nｍ1＄，j&
Dim Shｔ1ＡsWorksheeｔ，shAs Ｗorksheet,ｗb1AsWorkｂook
Application、ScrｅenUpdａｔinｇ=False
Ｓｅｔｗb1＝ＴhisWorkboｏk
ｗbnm=Lefｔ（wb1、Ｎａｍｅ, Lｅｎ（wb１、Ｎamｅ）— 4）
SeｔSht１=ActivｅＳheｅｔ
Shｔ1、[a2：
w２00]＝””
aa= Left（Shｔ１、Ｎame,２）
SeｔmyＦｓ=Ａpplicatioｎ、
myPaｔh =TｈisWorkbｏok、Pａｔh & "\”
WｉtｈmｙFｓ
、ＮｅwSearcｈ
、LｏｏkIn=myPath
、＝ mso
、="＊、xlｓ”
、SearｃhSubFｏlders= Tｒue
If 、Executｅ（ＳｏｒtBy:
=msoSorｔBｙ）> 0Ｔheｎ
ｎ =、Ｆound
ＲeDｉmmyfile（1Toｎ）ＡsStriｎｇ
For i＝１ Ton
mｙｆile（i） =、FounｄFiles（i）
＝mｙfilｅ（i）
nm1=Ｓpｌｉt（Mid（,ＩnＳtｒＲev（，"\”）+1）,"、”）（0）
Ifnm1＝ｗｂｎｍTheｎ GｏTo２00
Ｗorｋboｏｋs、Openmｙｆile（i）
Dim wb Ａs Ｗｏｒkbooｋ
Set ｗb=AcｔｉveWorkbｏoｋ
ForＥacｈｓhInＳｈeets
ＩｆInStｒ（ｓh、Naｍe,ａa）Tｈen
sh、Actｉvatｅ
Ifaａ=”班子”Thｅn
mm= mm+1
Brrbｚ（mm,１）＝[b2]、Value
Forj＝2Tｏ 18Ｓteｐ２
If ｊ＜10Theｎ
Brrbz（mm，ｊ） ＝Cells（j /2 + ３４，1１）、Vａｌｕe
Eｌse
Brｒbz（mm,j）=Cｅllｓ（ｊ／ 2+34，９）、Value
EndＩｆ
Neｘｔ
ＧｏTo1００
Else
If [b2］=""ThｅnGoTｏ50
mm = mm+1
Bｒｒgr（mm，１）=［b2］、Value
Ｂrrgr（mm,2）=［e３8]、Vaｌue
Brrｇr（mm，３） =[ｉ３８]、Ｖalue
Fｏrj=4Tｏ18Ｓtｅp2
Ifj<1２Tｈeｎ
Ｂｒrｇｒ（ｍm，j）=Ceｌｌs（ｊ／２ + 38,8）、Ｖaｌue
Eｌｓｅ
Bｒrgr（mm， j）=Cells（j／2+38,７）、Ｖａlue
EｎdＩf
Ｎext
Fｏr j=２０To23
Ｂｒrｇr（mm,j）＝Cells（j ＋28，8）、Vａlｕｅ
Ｎext
EndIｆ
ＥndＩf
50：
Neｘt
100：
ｗb、Ｃloｓesavechanges：
=Faｌse
Sｅｔｗb = Nothinｇ
200:
Ｎｅxt
Else
MｓgBox"该文件夹里没有任何文件"
EndIf
EndWｉth
Ifaａ=”班子"Then
[ａ2]、Rｅsize（mｍ，19） = Bｒrbｚ
Elｓe
[ａ2］、Resｉｚe（ｍm,23）=Brrgr
EｎｄIf
[ａ1]、Seｌｅcｔ
SetmyFs ＝Nothｉng
End Sub
‘201１-７-１５
‘
Subpｌdrsj（）
＇批量导入指定文件得数据ﻫ DimmyFsAｓ,myfiｌe, Bｒrﻫ Dｉm myPaｔh＄,$，nm2$ﻫ Ｄimi&， j&，n＆,aa$,nm＄ﻫ DimSht１ AsWｏrksｈeet，ｓh AsWoｒkshｅetﻫ Aｐplｉcaｔioｎ、ScreenＵpdａtinｇ=Ｆalｓe
SeｔSht1= ActiｖｅSheetﻫ Sht1、Celｌｓ、CｌearConｔentｓ
nm2= AｃtiveWｏrkboｏk、Ｎamｅ
SｅtmyＦs =Applｉcation、ﻫ ｍｙPath＝ThisWｏrkbｏｏk、Pａtｈ
Wｉｔh myFsﻫ 、NewSｅarch
、LookIn=myPaｔhﻫ 、=ｍsoﻫ 、＝”*、xls＂
、SeａｒcｈSｕｂＦolders=Trueﻫ If 、Exｅｃute（SoｒtＢy:
＝ｍsoSorｔBｙ）＞０Thenﻫ n=、Fouｎd
ReＤim Ｂｒr（1Tｏ
升级会员 