ExcelVBA多工作簿多工作表汇总实例集锦.docx

ExcelVBA多工作簿多工作表汇总实例集锦.docx

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

ExcelVBA多工作簿多工作表汇总实例集锦

1，多工作表汇总（Consolidate）

‘

‘两种写法都要求地址用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="XX"

EndSub

Subsumdemo（）

DimarrAsVariant

arr=Array（"一月!

R1C1:

R8C5","二月!

R1C1:

R5C4","三月!

R1C1:

R9C6"）

WithWorksheets（"汇总"）.Range（"A1"）

.Consolidatearr,xlSum,True,True

.Value="XX"

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）

‘2007-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，多工作表汇总（字典、数组）

‘

‘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

‘9188-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

‘

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