Excel VBA多工作簿多工作表实例集锦

1,多工作表汇总(Consolidate)

'两种写法都要求地址用R1C1形式，各个表格的数据布置有规定。

SubConsolidateWorkbook()

DimRangeArrayOAsString

DimbkAsWorksheet

DimshtAsWorksheet

DimWbCountAsInteger

Setbk=Sheets("汇总”)

WbCount=Sheets.Count

ReDimRangeArray(1ToWbCount-1)

ForEachshtInSheets

Ifsht.Name<>"汇总”Then

i=i+1

RangeArray(i)=&sht.Name&_

sht.Range("Al").CurrentRegion.Address(ReferenceStyle:=xlRlCl)

EndIf

Next

bk.Range("Al").ConsolidateRangeArray,xlSum,True,True

[a[.Value="姓名”

EndSub

Subsumdemo()

DimarrAsVariant

arr=Array("一月！RIC1:R8c5"，"二月！R1C1:R5c4"，“三

月!R1C1:R9c6”)

WithWorksheets("汇总”).Range(”Al”)

.Consolidatearr,xlSum,True,True

.Value="姓名”

EndWith

EndSub

2,多工作簿汇总(Consolidate)

'多工作簿汇总

SubConsolidateWorkbook()

DimRangeArrayOAsString

DimbkAsWorkbook

DimshtAsWorksheet

DimWbCountAsInteger

WbCount=Workbooks.Count

ReDimRangeArray(1ToWbCount-1)

ForEachbkInWorkbooks'在全部工作簿中循环

IfNotbkIsThisWorkbookThen'非代码所在工作簿

Setsht=bk.Worksheets⑴引用工作簿的第一个工作表

i=i+1

RangeArray⑴=”&bk.Name&nJ"&sht.Name&

&_

sht.Range("Al").CurrentRegion.Address(ReferenceStyle:=xlRlCl)

EndIf

Next

Worksheets(l).Range("A1").Consolidate_

RangeArray,xlSum,True,True

EndSub

3,多工作簿汇总()

'2007-1-l.html###

'help、汇总表.xls

Subpldrwb0531()

‘汇总表.xls

'导入指定文件的数据

DimmyFsAs

DimmyPathAsString,$

DimiAsLong,nAsLong

DimShtlAsWorksheet,shAsWorksheet

Dimaa,nm$,nml$,m,arr,rl,coll%

Application.ScreenUpdating=False

SetShtl=ActiveSheet

SetmyFs=Application.

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=n*.xlsu

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

coll=2

ReDimmyfile(1Ton)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

aa=InStrRev(,n\")

nm=Right(,Len()-aa)

nml=Left(nm,Len(nm)-4)

Ifnml<>"汇总表"Then

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

m=[a65536].End(xlUp).Row

arr=Range(Cells(3,3),Cells(m,3))

Shtl.Activate

coll=coll+1

Cells(2,coll)=nm'自动获得文件名

Cells(3,col1).Resize(UBound(arr),1)=arr

wb.Closesavechanges:=False

Setwb=Nothing

EndIf

Next

Else

MsgBox”该文件夹里没有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScrccnUpdating=True

EndSub

'依据上例增加了在一个工作簿中可选择多个工作表进行汇总，运用了文

本框多选功能

Publicar,arl,nm$

Subpldrwb0531()

'汇总表.xls

'导入指定文件的数据(默认工作表1的数据)

'干脆从C列依次导入

DimmyFsAs

DimmyPathAsString,$

DimiAsLong,nAsLong

DimShtlAsWorksheet,shAsWorksheet

Dimaa,nml$,m,arr,rl,coll%

Application.ScreenUpdating=False

OnErrorResumeNext

SetShtl=ActiveSheet

SetmyFs=Application.

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=M*.xlsu

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

col1=2

ReDimmyfile(lTon)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

aa=InStrRevf,"\")

nm=Right(,Len()-aa)

nml=Leftfnm,Len(nm)-4)

Ifnml<>"汇总表"Then

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

s=s&sh.Name&

Next

s=Left(s,Len(s)-1)

ar=Split(s,",H)

UserForml.Show

Forj=0ToUBound(arl)

IfErr.Number=9ThenGoTo100

Setsh=wb.Sheets(arl(j))

sh.Activate

m=sh.[a65536].End(xlUp).Row

arr=Range(Cells(3,3),Cells(m,3))

Shtl.Activate

coll=coll+1

Cells(2,coll)=sh.[al]

Cells(3,col1).FormulaR1C1=1,=|"&

nm&丫&arl(j)&”!RC3”'显示引用的工作簿工作表与单元格

地址

Cells(3,coll).AutoFillRange(Cells(3,

coll),Cells(UBound(arr)+2,coll))

'Cells(3,coll).Resize(UBound(arr),

1)=arr

Nextj

100:wb.Closesavechanges:=False

Setwb=Nothing

s="H

IfVarType(arl)=8200ThenErasearl

EndIf

Next

Else

MsgBox”该文件夹里没有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

PrivateSubCommandButtonl_Click()

Fori=0ToListBoxl.ListCount-1

IfListBox1.Selected(i)=TrueThen

s=s&ListBoxl.List(i)&

EndIf

Nexti

Ifs<>Then

s=Left(s,Len(s)-1)

arl=Split®"J)

MsgBox"你选择了"&s

UnloadUserForml

Else

mg=MsgBox("你没有选择任何工作表！须要重新选择吗？",vbYesNo,

"提示”)

Ifmg=6Then

Else

UnloadUserForml

EndIf

EndIf

EndSub

PrivateSubCommandButton2_Click()

UnloadUserForml

EndSub

PrivateSubUserForm_Initialize()

WithMe.ListBoxl

.List=ar'文本框赋值

.ListStyle=1'文本前加选择小方框

.MultiSelect=1'设置可多选

EndWith

Me.Label1.Caption=Me.Label1.Caption&nm

EndSub

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

4Data多表汇总0623.xls

Subdbhz()

‘多表汇总

DimShtlAsWorksheet,Sht2AsWorksheet,ShtAsWorksheet

Dimd,k,t,Myr&,Arr,x

Application.Screenupdating=False

Application.DisplayAlerts=False

Setd=CreateObjectf'Scripting.Dictionary")

ForEachShtInSheets'删除同名的表格，获得要增加的汇总表

格不重复名字

IfInStr(Sht.Name,n-")>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)

SetShtl=ActiveSheet

Shtl.Name=Replace(k(i),7\"-H)'增加汇总表，把名字中

的“/“(不能用作表名的)改为"-“

Nexti

Erasek

Setd=Nothing

ForEachShtInSheets

WithSht

.Activate

IfInStr(.Name,=0Then

nm=Replace(Mid(.[a3],7),

Myr=.[h65536].End(xlUp).Row

Arr=.Range("dlO:hM&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,l).Resize(l,2)=ArrayCPartNo.'；"TTL

Qty")

CellsflO,1).Resize(UBoundfk)+1,1)=

Application.Transpose(k)

CellsflO,2).Resize(UBound(t)+1,1)=

Application.Transpose(t)

Else

Cells(myr2,l).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,多工作簿提取指定数据()

^2011-8-31

*9188-1-l.html

SubGetDataf)

DimBrrbz(1To200,1To19),Brrgr(1To500,1To23)

DimmyFsAs,myfile

DimmyPathAsString,$,wbnm$

Dimi&,n&,mm&,aa$,nml$,j&

DimShtlAsWorksheet,shAsWorksheet,wblAsWorkbook

Application.ScreenUpdating=False

Setwb1=ThisWorkbook

wbnm=Left(wbl.Name,Len(wbl.Name)-4)

SetShtl=ActiveSheet

Shtl.[a2:w200]

aa=Left(Shtl.Name,2)

SetmyFs=Application.

myPath=ThisWorkbook.Path&"\"

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=n*.xlsn

.SearchSubFolders=True

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

ReDimmyfilef1Ton)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

nml=Split(Mid(,InStrRev(,"\")+1),n.")(0)

Ifnml=wbnmThenGoTo200

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

IfInStr(sh.Name,aa)Then

sh.Activate

Ifaa="班子"Then

mm=mm+1

Brrbzfmm,1)=[b2].Value

Forj=2To18Step2

Ifj<10Then

Brrbz(mm,j)=Cellsfj/2+34,

11).Value

Else

Brrbz(mm,j)=Cellsfj/2+34,

9).Value

EndIf

Next

GoTo100

Else

If[b2]=""ThenGoTo50

mm=mm+1

Brrgrfmm,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

SubpldrsjQ

'批量导入指定文件的数据

DimmyFsAs,myfile,Brr

DimmyPath$,$,nm2$

Dimi&,j&,n&,aa$,nm$

DimShtlAsWorksheet,shAsWorksheet

Application.ScreenUpdating=False

SetShtl=ActiveSheet

Shtl.Cells.ClearContents

nm2=ActiveWorkbook.Name

SetmyFs=Application.

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.="*.xls,r

.SearchSubFolders=True

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

ReDimBrr(lTon,1To2)

ReDimmyfile(1Ton)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

aa=InStrRevf,n\M)

nm=Right(,Len()-aa)'带后缀的Excel文件名

Ifnm<>nm2Then

j=j+1

Workbooks.Openrnyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

Setsh=wb.Sheets("Sheetl")

Brr(j,1)=nm

Brr(j,2)=sh.[c3].Value

wb.Closesavechanges:=False

Setwb=Nothing

EndIf

Next

Else

MsgBox'该文件夹里没有任何文件”

EndIf

EndWith

Shtl.Select

[a3].Resize(UBound(Brr),2)=Brr

SetmyFs=Nothing

Application.Screenupdating=True

EndSub

Subpldrsj0707()

,6387-1-l.html

'Report2.xls

’批量导入指定文件的数据

DimmyFsAs,myfile

DimmyPathAsString,$,ma&,mc&

DimiAsLong,nAsLong,nn&,aa$,nm$,nml$

DimShtlAsWorksheet,shAsWorksheet

Application.ScreenUpdating=False

SetShtl=ActiveSheet:nn=5

Shtl.[b5:e27]=M"

SetmyFs=Application.

myPath=ThisWorkbook.Path&"\data"'指定的子文件夹内

搜寻

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=n*.xlsu

.SearchSubFolders=True

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

ReDimmyfile(lTon)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

nml=spHt(mid((,"\M)+l),'，.，，)(O)一句代码代替以下3句

4aa=InStrRev(,"\")

'nm=Right(,Len()-aa)’带后缀的Excel文

件名

'nml=Leftfnm,Len(nm)-4)’去除后缀的

Excel文件名

Ifnml<>Shtl.NameThen

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

sh.Activate

ma=[b65536].End(xlUp).Row

Ifma>6Then'第6行是表头

Ifma>10Thenma=10

'只要取4行数据

Forii=7Toma

Shtl.Cells(nn,

2).Resizefl,3)=Cells(ii,2).Resize(l,3).Value

Shtl.Cells(nn,5)=

Cells(ii,6).Value

nn=nn+1

Nextii

GoTo100

Else

GoTo100

EndIf

me=[d65536].End(xlUp).Row

Ifme>7Then'第7行是表头

Ifme>11Thenme=11

'只要取4行数据

Forii=8Tome

Shtl.Cells(nn,

2).Resizefl,3)=Cells(ii,4).Resize(l,3).Value

Shtl.Cells(nn,5)=

Cellsfii,8).Value

nn=nn+1

Nextii

GoTo100

Else

GoTo100

EndIf

100:

Nextsh

wb.Closesavechanges:=Faise

Setwb=Nothing

EndIf

Next

Else

MsgBox”该文件夹里没有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

'sum.xls

Subpldrsj0724()

’批量导入指定文件的数据

DimmyFsAs,myfile,Myrl&,Arr

DimmyPath$,$,nm2$

Dimi&,j&,n&,nn&,aa$,nm$,nml$

DimShtlAsWorksheet,shAsWorksheet

Application.ScreenUpdating=False

SetShtl=ActiveSheet

Myrl=Sht1.[a65536].End(xlUp).Row

Arr=Shtl.Range("a3:b"&Myrl)

Shtl.Range("b3:b"&Myr1).ClearContents

nm2Left(ActiveWorkbook.Name,

Len(ActiveWorkbook.Name)-4)

SetmyFs=Application.

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

ReDimmyfile(lTon)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

aa=InStrRev(,u\")

nm=Right(,Len()-aa)'带后缀的Excel文件

名

nml=Left(nm,Len(nm)-4)'去除后缀的

Excel文件名

Ifnml<>nm2Then

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

Forj=1ToUBound(Arr)

Ifsh.Name=Arr(j,1)Then

sh.Activate

Setrl

Range(Hc:c").Find(sh.Name)

nn=rl.Row

Arr(j,2)=Cells(nn,9)

GoTo100

EndIf

Nextj

Nextsh

100:

wb.Closesavechanges:=False

Setwb=Nothing

EndIf

Next

Else

MsgBox”该文件夹里没有任何文件”

EndIf

EndWith

Shtl.Select

[b3].Resize(UBound(Arr),1)=Application.Index(Arr,0,2)

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

6,多工作表提取指定数据（数组）

Subfpkf()

Application.ScreenUpdating=False

DimMyr&,Arr,yf,x&,Myrl&,rl

DimShtAsWorksheet

Myr=Sheet1.[b65536].End(xlUp).Row

Sheetl.Range("c8:hH&Myr).ClearContents

Arr=Sheetl.Range("c8:h"&Myr)

[j8|.Formula=,,=rc[-9]&"M|H,,&rc[-8]"

[j8].AutoFillRange("j8:j"&Myr)

Range("j8:jH&Myr)=Range("j8:j"&Myr).Value

ForEachShtInSheets

IfSht.Name<>Sheet1.NameThen

yf=Left(Sht.Name,Len(Sht.Name)-2)

Sht.Activate

Myrl=[a65536].End(xlUp).Row-1

Forx=7ToMyrl

IfCellsfx,1)<>""Then

Setrl=Sheetl.Range("j:jn).Find(Cells(x,1)&"|"&

Cells(x,2))

IfNotrlIsNothingThen

Arr(rl.Row-7,yf)=Cellsfx,"arn)

EndIf

EndIf

Nextx

EndIf

Next

Sheet1.Activate

[c8].Resize(UBound(Arr),UBound(Arr,2))=Arr

[j:j].Clear

Application.ScreenLJpdating=True

EndSub

7,多工作簿多工作表查询汇总去重复值（字典数组）

'具体记录.xls

'3个工作漕须要都打开

Subxxjl()

DimShtlAsWorksheet,ShtAsWorksheet

DimwblAsWorkbook,wb2AsWorkbook,wb3AsWorkbook

Dimi&,Myr2&,Arr2,Myr&,Arr,Myrl&,xm$,yl$

Application.ScreenUpdating=False

Setwb1=ActiveWorkbook

Setwb2=Workbooks("购进")

Setwb3=Workbooks("配料")

wb2.Activate

Myr2=[a65536].End(xlUp).Row

Arr2=Range(匕2:d"&Myr2)

wb3.Activate

Fori=1ToUBound(Arr2)

wb3.Activate

xm=Arr2(i,2)

ForEachShtInSheets

IfSht.Name=xmThen

Sht.Activate

Myr=[a65536].End(xlUp).Row

Arr=Range("al:b"&Myr)

Forj=1ToUBound(Arr)

yl=Arr(j,1)

wbl.Activate

ForEachShtlInSheets

IfShtl.Name=ylThen

Shtl.Activate

Myrl=[a65536].End(xlUp).Row+1

Cells(Myrl,1)=Arr2(i,1)

Cells(Myrl,3)=Arr2(i,3)

Cells(Myrl,2)=Arr2(i,4)*Arr(j,2)

ExitFor

EndIf

Next

Nextj

GoTo100

EndIf

Next

100:

Nexti

Callqccf

Application.ScreenLJpdating=True

EndSub

Subqccf()

DimShtAsWorksheet,Myr&,Arr,i&,x

Dimd,k,t,Arrl,j&

Application.ScreenUpdating=False

ForEachShtInSheets

Sht.Activate

Myr=[a65536].End(xlUp).Row

Arr=Range(匕2: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

ReDimArrlflToUBound(k)+1,1To3)

Forj=0ToUBound(k)

Arrl(j+1,1)=Split(k(j),",")(0)

Arrl(j+1,3)=Split(k(j),"：)(1)

Arrl(j+l,2]=t(j)

Nextj

Range("a2:c"&Myr).ClearContents

[a2].Resize(UBound(Arr1),3)=Arrl

100:

Setd=Nothing

Next

Application.Screenupdating=True

EndSub

8,多工作簿对比()

SubdgzbdbQ

'多工作簿对比

'by:蓝桥2009-11-7

DimmyFsAs

DimmyPathAsString,$

Dimi&,n&,nm$,myShtlAsWorksheet,shAsWorksheet

DimwblAsWorkbook,yf,j&,ml&

Dimm,arr,rl

Application.ScreenUpdating=False

Application.DisplayAlerts=False

OnErrorResumeNext

Setwb1=ThisWorkbook

SetmyFs=Application.

myPath=ThisWorkbook.Path

ForEachShtlInSheets

IfInStr(Shtl.[al],”费用明细表”)>0Then

nm=Left(Shtl.[al],Len(Shtl.[al]l-5)

Shtl.Activate

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=nm&".xls"

.SearchSubFolders=True

If.Execute(SortBy:=msoSortBy)>0Then

myfile=.FoundFiles(l)

Workbooks.Openmyfile

DimwbAsWorkbook

Setwb=ActiveWorkbook

Setsh=wb.ActiveSheet

m=sh.[a65536].End(xlUp).Row

arr=sh.RangefCells(2,1),Cells(m,6))

yf=Val(Split(arr(2,1),".")(1))

Shtl.Activate

Forj=1ToUBound(arr)

Setrl=Sht1.Range("c:c*j.Find(arr(j,3))

IfrlIsNothingThen

ml=Sht1.[d65536].End(xlUp).Row

Cells(ml,l).EntireRow.Insertshift:=xlUp

Cells(ml,1)=Cells(ml-1,1)+1

Cells(ml,2)=arr(j,3)

Cells(ml,yf+3)=arr(j,6)

EndIf

Nextj

wb.Closesavechanges:=False

Setwb=Nothing

EndIf

EndWith

EndIf

Next

SetmyFs=Nothing

Application.DisplayAlerts=True

Application.ScreenUpdating=True

EndSub

9,多工作簿汇总（字典）

Subpldrwb1123()

'合并.xls

’导入指定文件的数据

DimmyFsAs

DimmyPathAsString,$

Dimi&,n&,y&,bb,j&,x

DimShtlAsWorksheet,shAsWorksheet

Dimaa,nm$,nml$,m,Arr,rl,mm&

Dimd,k,t,dl,tl

Application.ScreenUpdating=False

mm=8

SetShtl=ActiveSheet

Shtl.[a8:hl000].ClearContents

SetmyFs=Application.

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.Lookin=myPath

.=mso

.=M*.xlsu

.SearchSubFolders=True

If.Execute(SortBy:=msoSortBy)>0Then

n=.Found

ReDimmyfile(lTon)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

=myfile(i)

aa=InStrRevf,u\")

nm=Right(,Len()-aa)

nml=Left(nm,Len(nm)-4)

Ifnml<>“合并"Then

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

m=[a65536].End(xlUp).Row

Arr=Range(Cells(8.1),Cells(m,7))

Setd=CreateObject("Scripting.Dictionary")

Setdl=CreateObjectf'Scripting.Dictionary")

Forj=1ToUBound(Arr)

x=Year(Arr(j,li)&”年"&Month(Arr(j,1))

&“月"&"|"&Arr(j,2)&T&Arr(j,3)&T&Arr(j,5)

d(x)=d(x)+Arr(j,4)

dl(x)=Arr(j,7)

Next

k=d.keys

t=d.items

tl=dl.items

Shtl.Activate

Fory=0ToUBound(k)

bb=Split(k(y),M|")

Cells(mm,1)=nml

Cells(mm,2)=bb(O)

Cells(mm,3)=bb(l)

Cells(mm,4)=bb(2)

Cells(mm,5)=t(y)

Cells(mm,6)=bb⑶

Cells(mm,7)=t(y)*bb(3)

Cellsfmm,8)=tl(y)

mm=mm+1

Next

wb.Closesavechanges:=False

Setwb=Nothing

Setd=Nothing

Setdl=Nothing

EndIf

Next

Else

MsgBox”该文件夹里没有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

10,多工作簿多工作表提取数据(D。While)

'年度汇总.xls

Subndhz()

DimArr,myPath$,myName$,wbAsWorkbook,shAs

Worksheet

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("Al").CurrentRegion

ForEachshInwb.Sheets

shnm=sh.Name

sh.Activate

IfInStrfshnm,>0Then

col=11

Else

col=7

EndIf

Fori=2ToUBound(Arr)

IfArr(i,col)=shnmThen

m=sh.[a65536].End(xlUp).Row+1

Cells(m,l).Resize(l,12)

Application.IndexfArr,i,0)

EndIf

Next

Next

.CloseFalse

EndWith

myName=Dir

Loop

Application.ScreenUpdating=True

EndSub

Subtqsj()

DimArr,myPath$,myName$,wbAsWorkbook,shAs

Worksheet

Dimm&,funm$,shnm$,col%,i&,Myr&,ShtlAsWorksheet,

pm$

Application.ScreenUpdating=False

OnErrorResumeNext

SetShtl=ActiveSheet

[a2:gl000].ClcarContcnts

funm="提取数据.xls”:m=1

myPath=ThisWorkbook.Path&"\"

myName=Dir(myPath&"*.xls")

DoWhilemyName<>""AndmyName<>funm

WithGetObjectfmyPath&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

WithShtl

.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

'我想要的结果.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("Sheetr')

m=sh.[a65536].End(xlUp).Row

Arr=sh.Range("a2:f"&m)

Cells(n,l).Resize(m-1,6)=Arr

n=n+m-1

.CloseFalse

EndWith

myName=