excelvba多工作簿多工作表汇总实例集锦Word下载.docx

excelvba多工作簿多工作表汇总实例集锦Word下载.docx

《excelvba多工作簿多工作表汇总实例集锦Word下载.docx》由会员分享，可在线阅读，更多相关《excelvba多工作簿多工作表汇总实例集锦Word下载.docx（92页珍藏版）》请在冰豆网上搜索。

"

Then

i=i+1

RangeArray（i）="

"

&

！

_

（"

A1"

）.（ReferenceStyle:

=xlR1C1）

EndIf

Next

）.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=

（1）'

引用工作簿的第一个工作表

["

]"

!

_（"

=xlR1C1）EndIf

Worksheets

（1）.Range（"

）.Consolidate_

RangeArray,xlSum,True,TrueEndSub

3，多工作簿汇总（FileSearch）

‘2007-1-1‘汇总表.xls

Subpldrwb0531（）

汇总表.xls

导入指定文件的数据

DimmyFsAsFileSearch

DimmyPathAsString,Filename$

DimiAsLong,nAsLong

DimSht1AsWorksheet,shAsWorksheet

Dimaa,nm$,nm1$,m,arr,r1,col1%=False

SetSht1=ActiveSheet

SetmyFs=myPath=WithmyFs

.NewSearch

.LookIn=myPath

.FileType=msoFileTypeNoteItem

.Filename="

*.xls"

If.Execute（SortBy:

=msoSortByFileName）>

0Thenn=.

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<

汇总表"

myfile（i）

DimwbAsWorkbookSetwb=ActiveWorkbookm=[a65536].End（xlUp）.Rowarr=Range（Cells（3,3）,Cells（m,3））

col1=col1+1

[a1].Select

SetmyFs=Nothing=TrueEndSub

‘根据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文本框多选功能Publicar,ar1,nm$

导入指定文件的数据（默认工作表1的数据）

直接从C列依次导入

Dimaa,nm1$,m,arr,r1,col1%

=False

OnErrorResumeNext

SetmyFs=

myPath=WithmyFs

col1=2ReDimmyfile（1Ton）AsString

DimwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

s=s&

s=Left（s,Len（s）-1）ar=Split（s,"

Forj=0ToUBound（ar1）

If=9ThenGoTo100

Setsh=（ar1（j））

m=sh.[a65536].End（xlUp）.Rowarr=Range（Cells（3,3）,Cells（m,3））

Cells（UBound（arr）+2,col1））

Cells（3,col1）.Resize（UBound（arr）,1）=arr

Nextj

savechanges:

=FalseSetwb=Nothings="

IfVarType（ar1）=8200ThenErasear1EndIf

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

Else

MsgBox"

PrivateSubCommandButton1_Click（）

Fori=0To-1

If（i）=TrueThens=s&

（i）&

Nexti

Ifs<

Thens=Left（s,Len（s）-1）ar1=Split（s,"

）MsgBox"

你选择了"

sUnloadUserForm1Elsemg=MsgBox（"

你没有选择任何工作表！

需要重新选择吗"

vbYesNo,"

提示"

）Ifmg=6Then

UnloadUserForm1

PrivateSubCommandButton2_Click（）

PrivateSubUserForm_Initialize（）

With

.List=ar

.ListStyle=1

.MultiSelect=1

文本框赋值‘文本前加选择小方框‘设置可多选

=&

nmEndSub

4，多工作表汇总（字典、数组）

pid=2928374&

page=1&

extra=page%3D1

‘Data多表汇总

Subdbhz（）

多表汇总

DimSht1AsWorksheet,Sht2AsWorksheet,ShtAsWorksheet

Dimd,k,t,Myr&

Arr,x

Setd=CreateObject（"

ForEachShtInSheets‘删除同名的表格，获得要增加的汇总表格不重复名字IfInStr,"

-"

）>

0Then:

GoTo100nm=Mid（Sht.[a3],7）d（nm）="

100:

NextSht=Truek=

Fori=0ToUBound（k）after:

=Sheets

增加汇总表，把名字中的”/”（不能用作表名的）

SetSht1=ActiveSheet=Replace（k（i）,"

/"

"

）改为”-“NextiErasekSetd=NothingForEachShtInSheets

WithSht

.Activate

IfInStr（.Name,"

）=0Thennm=Replace（Mid（.[a3],7）,"

）Myr=.[h65536].End（xlUp）.RowArr=.Range（"

d10:

h"

Myr）Setd=CreateObject（"

）Fori=1ToUBound（Arr）

x=Arr（i,1）

IfNot（x）Then

x,Arr（i,5）

d（x）=d（x）+Arr（i,5）

Nextk=

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）=（k）

Cells（10,2）.Resize（UBound（t）+1,1）=（t）

Cells（myr2,1）.Resize（UBound（k）+