1,多工作表匯總(Consolidate)

'http:〃www.excelpx.com/dispbbs.asp?boardID=5&ID=l10630&page=l

'兩種寫法都要求地址用R1C1形式，各個表格的數(shù)據(jù)布置有規(guī)定。

SubConsolidateWorkbook()

DimRangcArray()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("Al").CurrentRegion.Address(ReferenceStyle:=xlRIC1)

EndIf

Next

bk.Range(z，Al，z).ConsolidateRangeArray,xlSum,True,True

[al].Value="姓名"

EndSub

Subsumdemo()

DimarrAsVariant

arr=Array("一月！R1C1:R8c5”,〃二月！R1C1:R5c4”,〃三月！RIC1:R9c6”)

WithWorksheets("匯總”).Range("Al")

.Consolidatearr,xlSum,True,True

.Value=〃姓名〃

EndWith

EndSub

2,多工作簿匯總(Consolidate)

'多工作簿匯總

SubConsolidatcWorkbook()

DimRangeArray()AsSiring

DimbkAsWorkbook

DimshtAsWorksheet

DimWbCountAsInteger

WbCount=Workbooks.Count

ReDimRangeArray(1ToWbCount-1)

ForEachbkInWorkbooks'在所有工作簿中循環(huán)

IfNotbkIsThisWorkbookThen'非代碼所在工作簿

Setsht=bk.Worksheets。)'引用工作簿的第一個工作表

i=i+1

RangeArray(i)="'["&bk.Name&&sht.Name&&

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

EndIf

Next

Worksheets(1).Range("Al〃).Consolidate_

RangeArray,xlSum,True,True

EndSub

3,多工作簿匯總(FileSearch)

'http:〃club,excelhome,net/thread-442007-1-1,html###

，help\匯總表.xls

Subpldrwb0531()

'匯總表.xls

'導(dǎo)入指定文件的數(shù)據(jù)

DimmyFsAsFi1eSearch

DimmyPathAsString,Filenames

DimiAsLong,nAsLong

DimShtlAsWorksheet,shAsWorksheet

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

Application.ScreenUpdating=False

SetShtl=ActiveSheet

SetmyFs=Application.Fi1eSearch

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.LookIn=myPath

.FileType=msoFileTypeNoteltem

.Filename=xls”

If.Execute(SortBy：-msoSortByFileName)>0Then

n=.FoundFiles.Count

col1=2

ReDimmyfile(1Ton)AsSti'ing

Fori=1Ton

myfile(i)=.FoundFiles(i)

Filename=myfile(i)

aa=InStrRev(Filename,"\")

nm=Right(Filename,Len(Filename)-aa)

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

Ifnml<>"匯總表"Then

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

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

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

Shtl.Activate

coll=coll+1

Cells(2,coll)=nm'自動獲取文件名

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

wb.Closesavechanges:=False

Setwb=Nothing

EndIf

Next

Else

MsgBox"該文件夾里沒有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

'根據(jù)上例增加了在一個工作簿中可選擇多個工作表進行匯總，運用了文本框多選功能

Pub1icar,arl,nm$

Subpldrwb0531()

'匯總表.xls

'導(dǎo)入指定文件的數(shù)據(jù)(默認工作表1的數(shù)據(jù))

'直接從C列依次導(dǎo)入

DimmyFsAsFileSearch

DimmyPathAsString,Filenames

DimiAsLong,nAsLong

DimShtlAsWorksheet,shAsWorksheet

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

Application.ScreenUpdating=False

OnErrorResumeNext

SetShtl=ActiveSheet

SetmyFs=Application.FileSearch

myPalh=ThisWorkbook.Path

WithmyFs

.NewSearch

.LookIn=myPath

.FileTypo=msoFileTypcNoteltem

.Filename=〃*.xls”

If.Execute(SortBy:=msoSortByFi1eName)>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(Fi1ename)-aa)

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

Ifnml<>"匯總表"Then

Workbooks.Openmyfile(i)

DinwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

s=s&sh.Name&”

Next

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

ar=Split(s,

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),CelIs(m,3))

Shtl.Activate

coll=coll+1

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

Cells(3,colD.FormulaRlCl=&nm&丁&arl(j)

&”!RC3〃'顯示引用的工作簿工作表及單元格地址

Cel1s(3,coll).AutoFil1Range(CelIs(3,cell),

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

*Cells(3,coll).Resize(UBound(arr),1)=arr

Nextj

100:wb.Closesavechanges:=False

Setwb=Nothing

IfVarType(arl)=8200ThenErasearl

EndIf

Next

Else

MsgBox〃該文件夾里沒有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

PrivateSubCommandButtonlClick()

Fori=0ToListBoxl.ListCount-1

IfListBoxl.Selected(i)=TrueThen

s=s&ListBoxl.List(i)&”,〃

EndIf

Nexti

Ifs<>""Then

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

arl=Split(s,

MsgBox"你選擇了"&s

UnloadUserForml

Else

mg=MsgBox(“你沒有選擇任何工作表！需要重新選擇嗎？",vbYesNo,"提示")

Ifmg=6Then

Else

UnloadUserForml

EnclIf

EndIf

EndSub

PrivateSubCommandButton2Click()

UnloadUserForml

EndSub

PrivateSubUserFoi-mInitializeO

WithMe.ListBoxl

.List=ar'文本框賦值

.ListStyle=1'文本前加選擇小方框

.MultiSelect=1'設(shè)置可多選

EnclWith

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

EnclSub

4,多工作表匯總(字典、數(shù)組)

'htlp:〃club,excelhome.net/viewthread.php?tid=450709&pid=2928374&page=l&extra=

page%3Dl

4Data多表匯總0623.xls

Subdbhz()

'多表匯總

DimShtlAsWorksheet,Sht2AsWorksheet,ShtAsWorksheet

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

Application.ScreenUpdating=False

Application.DisplayAlerts=False

Setd=CrealeObject("Scripting.Dictionary")

ForEachShtInSheets'刪除同名的表格，獲得要增加的匯總表格不重復(fù)名字

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)

SetShtl=ActiveSheet

Shtl.Name=Replace(k(i),〃/",f'增加匯總表,把名字中的"/"(不能用

作表名的)改為"-“

Nexti

Erasek

Setd=Nothing

ForEachShtInSheets

WithSht

.Activate

IfInStr(.Name.=0Then

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

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

Arr=.Range("d1():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].Bnd(x1Up).Row+1

Ifmyr2<9Then

Cells(9,1).Resized,2)=Array「PartNo.","TTLQty")

Cells(10,1).Resize(UBound(k)+1,1)=Appliceition.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,多工作簿提取指定數(shù)據(jù)(FileSearch)

42011-8-31

*http://club.excelhome,net/thread-759188-1-1.html

SubGetDataO

DimBrrbzdTo200,1To19),Brrgr(lTo500,1To23)

DimmyFsAsFileSearch；myfile

DimmyPathAsString,Filcnamc$,wbnm$

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

DimSht1AsWorksheet,shAsWorksheet,wblAsWorkbook

App1ication.ScreenUpdaling=False

Setwbl=ThisWorkbook

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

SetSht1=?\ctiveSheet

Shtl.[a2:w200]=

aa=Left(Shtl.Name,2)

SetmyFs=Application.FileSearch

myPath=ThisWorkbook.Path&"\"

WithmyFs

.NewScarch

.LookIn=myPath

.FileType=msoFileTypeNoteltem

.Filename=xls”

.SearchSubFolders=True

If.Execute(Sortliy:=msoSortByFileName)>0Then

n=.FoundFiles.Count

RoDimmyfiledTon)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

Filename=myfile(i)

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

Ifnml=wbnmThenGoTo200

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Setwb=ActiveWorkbook

ForEachshInSheets

IfInStr(sh.Name,aa)Then

sh.Activate

Ifaa=〃班子〃Then

mm=mm+1

Brrbz(nun,1)=[b2].Value

Forj=2To18Step2

Ifj<10Then

Brrbz(mm,j)=Cells(j/2+34,11).Value

Else

Brrbz(mm,j)=CelIs(j/2+34,9).Value

EndIf

Next

GoTo100

Else

If[b2]=ThenGoTo50

mm=mm+1

Brrgr(mm,I)=[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)=CelIs(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

[al].Select

SetmyFs=Nothing

EndSub

42011-7-15

'htip:〃club,excelhome,net/viewthread.php?tid=741341&pid=5036524&page=l&extra=

Subpldrsj0

'批量導(dǎo)入指定文件的數(shù)據(jù)

DimmyFsAsFileSearch,myfile,Brr

DimmyPath$,Filenames,nm2$

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

DimShtlAsWorksheet,shAsWorksheet

App1ication.Screenlpdating=False

SetShtl=ActiveSheet

Shtl.Cells.ClearContents

nm2=ActiveWorkbook.Name

SetmyFs=Application.FileScarch

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.LookIn=myPath

.FileType=msoFileTypeNoteltem

.Filename=xls”

.SoarchSubFolders=True

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

n=.FoundFiles.Count

ReDimBrr(lTon,1To2)

ReDimmyfile(lTon)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.C1osesavechanges:=False

Setwb=Nothing

EndIf

Next

Else

MsgBox〃該文件夾里沒有任何文件〃

EndIf

EndWith

Shtl.Select

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

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

SubpldrsjO7O7()

'http://club.excelhome.net/thread-456387-1-1,html

'Report2.xls

'批量導(dǎo)入指定文件的數(shù)據(jù)

DimmyFsAsFilcScarch,myfi1e

DimmyPathAsString,Filenames,ma&,mc&

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

DimShtlAsWorksheet,shAsWorksheet

Application.Screenupdating=False

SetShtl=ActiveSheet:nn=5

Shtl.[b5:e27]=

SetmyFs=Application.FileSearch

myPath=ThisWorkbook.Path&"\data"，指定的子文件夾內(nèi)搜索

WithmyFs

.NewScarch

.LookIn=myPalh

.FileType=msoFi1eTypeNoteItem

.Fi1ename="*.xls”

.SearchSubFolders=True

If.Execute(SortBy:=msoSoi'tByFi1eNamc)>0Then

n=.FoundFiles.Count

ReDimmyfile(1Ton)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

Filename=myfile(i)

nml=split(mid(filename,instrrev(filename,(0)?句

代碼代替以下3句

'aa=InStrRev(Filename,"\")

*nm=Right(Filename,Len(Filename)-aa)'帶后綴的Excel

文件名

'nml=Left(nm,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行數(shù)據(jù)

Forii=7Toma

Shtl.Cells(nn,2).Resized,3)=Cells(ii,

2).Resized,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行數(shù)據(jù)

Forii=8Tome

ShtLCelIs(nn,2).Resized,3)=Cells(ii,

4).Resized,3).Value

Sht1.Cells(nn,5)=Cells(ii,8).Value

nn=nn+1

Nextii

GoTo100

Else

GoTo100

EndIf

100:

Nextsh

wb.Closesavechanges:=False

Setwb=Nothing

EndIf

Next

Else

MsgBox”該文件夾里沒有任何文件”

EndIf

EndWith

[al].Select

SetmyFs=Nothing

Application.ScreenUpdating=True

EndSub

'http:〃club,excelhome,net/viewthread.php?tid=46271O&pid=3020658&page=l&extra=

page%3D2

'sum.xls

Subpldrsj0724()

'批量導(dǎo)入指定文件的數(shù)據(jù)

DimmyFsAsFileSearch,myfile,Myrl&,Arr

DimmyPathS,Filenames,nm2$

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

DimShtlAsWorksheet,shAsWorksheet

Application.ScreenUpdating=False

SetShtl=ActiveSheet

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

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

Shtl.Range("b3:b〃&Myrl).ClearContents

nm2=Loft(ActivcWorkbook.Name,Lon(ActiveWorkbook.Name)-4)

SetmyFs=Application.FileSearch

myPath=ThisWorkbook.Path

WithmyFs

.NewSearch

.LookIn=myPath

.FileType=msoFileTypeNoteltem

.Filename="*.xls”

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

n=.FoundFiles.Count

ReDimmyfile(1Ton)AsString

Fori=1Ton

myfile(i)=.FoundFiles(i)

Filename=myfile(i)

aa=InStrRev(Filename,"\")

nm=Right(Filename,Len(Filename)-aa)'帶后綴的Excel文

件名

nml=Left(nm,I,en(nm)-4)'去除后綴的Excel文件名

Ifnml<>nm2Then

Workbooks.Openmyfile(i)

DimwbAsWorkbook

Sotwb=ActivcWorkbook

ForEachshInSheets

Forj=1ToUBound(Arr)

Ifsh.Name=Arr(j,1)Then

sh.Activate

Setrl=RangeCc: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

Sht1.Select

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

SetmyFs=Nothing

Appliccition.ScreenUpdating=True

EnclSub

6,多工作表提取指定數(shù)據(jù)(數(shù)組)

'http:〃excel,aa.topzj.com/viewthread.php?tid=399457&pid=73718&pagc=l&extra=#p

id73718

Subfpkf()

Application.ScreenUpdating=False

DimMyr&,Arr,yf,x&,Myrlft,rl

DimShtAsWorksheet

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

Sheet1.Rangc(z，c8:h，/&Ifyr).ClcarContcnts

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

[j8].Formula=*=rc[-9]|**&rc[-8]*

[j8].AutoFillRange&Myr)

Range("j8:j"&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=7ToMyr1

IfCells(x,1)<>""Then

Setrl=Sheet1.Range("j:j?，).Find(CelIs(x,1)&&Cells(x,2))

IfNotrlIsNothingThen

Arr(rl.Row-7,yf)=Cells(x,"ar")

EndIf

EndIf

Nextx

EndIf

Next

Sheetl.Activate

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

Clear

Application.ScreenUpdating=True

EndSub

7,多工作簿多工作表查詢匯總?cè)ブ貜?fù)值(字典數(shù)組)

'http:〃club,excelhome,net/viewthread.php?tid=485193&pid=3181286&page=l&extra=

page%3Dl

'詳細記錄.xls

'3個工作簿需要都打開

Subxxjl()

DimSht1AsWorksheet,ShtAsWorksheet

DimwblAsWorkbook,wb2AsWorkbook,wb3AsWorkbook

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

Application.ScreenUpdating=False

Setwbl=ActiveWorkbook

Setwb2=Workbooks("購進”)

Setwb3=Workbooks("配料”)

wb2.Activate

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

Arr2=Range("a2: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=1ToCBound(Arr)

yl=Arr(j,1)

wb1.Activate

ForEachShtlInSheets

IfShtl.Name=ylThon

Shtl.Activate

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

CelIs(Myrh1)=Arr2(i,1)

CelIs(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.ScreenUpdating=True

EndSub

Subqccf()

DimShtAsWorksheet,jfyr&,Arr,i&,x

Dimd,k,t,Arrl,j&

App1ication.ScreenUpdaling=False

ForEachShtInSheets

Sht.Activate

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

Arr=Range(*a2: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

ReDimArrl(lToUBound(k)+1,1To3)

Forj=0ToUBound(k)

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

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

Arrl(j+1,2)=t(j)

Nextj

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

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

100:

Setd=Nothing

Next

Application.ScreenUpdating=True

EndSub

8,多工作簿對比(FileSearch)

'http:〃club,excelhome,net/viewthread.php?tid=499599&pid=3285214&page=l&extra=

page%3Dl

SubdgzbdbO

'多工作簿對比

'by:藍橋2009T1-7

DimmyFsAsFileSearch

DimmyPathAsString,Filename$

Dimi&,n&,nm$,myfile

DimSht1AsWorksheet,shAsWorksheet

DimwblAsWorkbook,yf,j&,ml&

Dimm,arr,rl

Application.ScreenUpdating=False

App1ication.DisplayA1erts=False

OnErrorResumeNext

Setwbl=ThisWorkbook

SetmyFs=Application.FileSearch

myPath=ThisWorkbook.Path

ForEachSht1InSheets

IfInStr(Shtl.[al],“費用明細表”)>0Then

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

Sht1.Activate

WithmyFs

.NewSearch

.LookIn=myPath

.FileType=msoFileTypeNoteltem

.Filename=nm&xls”

.SearchSubFolders=True

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

myfile=.FoundFiles(1)

Workbooks.Openmyfile

Dim\vbAsWorkbook

Setwb=ActiveWorkbook

Setsh=wb.ActiveSheet

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

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

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

Sht1.Activate

Forj=1ToUBound(arr)

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

IfrlIsNothingThen

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

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

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

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

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

EndIf

Nextj

wb.Closesavechanges:=Fa1se

Setwb=Nothing

EndIf

EndWith

EndIf

Next

SetmyFs=Nothing

Application.DisplayAlerts=