VBA開啟文件夾下所有文件

本文格式為Word版，下載可任意編輯——VBA開啟文件夾下所有文件

‘subxlsOpen()

Setrrr=CreateObject(\Setr=rrr.GetFolder(\練習(xí)\\\

Application.ScreenUpdating=FalseForEachiInr.Files

Workbooks.OpenFilename:=(\練習(xí)\\\Sheets(1).Cells(2,5)=“10〞

ActiveWorkbook.Closesavechanges:=trueNext

Application.ScreenUpdating=True‘EndSubExecuteExcel4Macro\‘打印當前SHEET

ActiveWorkbook.Closesavechanges:=false‘不保存關(guān)閉ActiveWorkbook.Closesavechanges:=true‘保存關(guān)閉setrrr=CreateObject(\‘subSHEET,range

Setr=rrr.GetFolder(\練習(xí)\Application.ScreenUpdating=FalseForEachiInr.Files

Workbooks.OpenFilename:=(\練習(xí)\\\‘+=&Sheets(1).SelectRange(\

ActiveCell.FormulaR1C1=\

ActiveWorkbook.Closesavechanges:=true

Next

Application.ScreenUpdating=True‘EndSub

Dimwjm‘Subdir用法

wjm=Dir(\練習(xí)\\*.xls\MsgBoxwjm

DoWhilewjm\當指定路徑中有文件時進行循環(huán)MsgBoxwjm

wjm=Dir:'找尋下一個*.xls文件Loop‘EndSubdir用法

DimMyPath$,MyName$,shAsWorksheet,arr‘SUB能用原版Setsh=ActiveSheet

MyPath=ThisWorkbook.Path&\

MyName=Dir(MyPath&\Application.ScreenUpdating=False

[a1].CurrentRegion.Offset(2).ClearContentsDoWhileMyName\

IfMyNameThisWorkbook.NameThenWithGetObject(MyPath&MyName).CloseFalseEndWithEndIf

MyName=DirLoop

Application.ScreenUpdating=True

MsgBox\‘endsub能用原版

DimMyPath$,MyName$,shAsWorksheet,arr‘sub能用改版

MyPath=(\練習(xí)\\\‘MyPath=ThisWorkbook.Path&\MyName=Dir(MyPath&\Application.ScreenUpdating=False

DoWhileMyName\‘IfMyNameThisWorkbook.NameThen

WithGetObject(MyPath&MyName)‘Workbooks.Open(MyPath&MyName).Sheets(1).Cells(2,7)=MyPath&MyName‘Sheets(1).Cells(2,7)=“1”Windows(MyName).Visible=True

.Closesavechanges:=True‘ActiveWorkbook.Closesavechanges:=trueEndWithEndIf

MyName=DirLoop

Application.ScreenUpdating=TrueMsgBox\‘EndSub能用改版

DimMyPath$,MyName$,shAsWorksheet,aasInteger‘sub寫入所有文件全名MyPath=(\練習(xí)\\\‘MyPath=ThisWorkbook.Path&\MyName=Dir(MyPath&\Application.ScreenUpdating=Falsea=1

DoWhileMyName\IfMyNameThisWorkbook.NameThen

WithGetObject(MyPath&MyName)‘Workbooks.Open(MyPath&MyName).Sheets(1).Cells(2,7)=MyPath&MyName‘Sheets(1).Cells(2,7)=“1”ActiveWorkbook.Sheets(1).Cells(a,1)=MyPath&MyNameWindows(MyName).Visible=True

.Closesavechanges:=True‘ActiveWorkbook.Closesavechanges:=trueEndWitha=a+1EndIf

MyName=DirLoop

Application.ScreenUpdating=True

MsgBox\’EndSub寫入所有文件全名

DimMypathAsString‘SUB寫入到A:ADimMynameAsString

Dimarr(1To1000,1To1)AsStringDimkAsInteger

Mypath=(\練習(xí)\\\Myname=dir(Mypath&\DoWhileMyname\k=k+1

arr(k,1)=Myname

Myname=dirLoop

Columns(\

Cells(1,1).Resize(UBound(arr),1)=arrMsgBox\‘ENDSUB寫入到A:A

SubWorkbooks(\‘Windows(\‘Endsub

subActiveWindow.Visible=FalseWorkbooks(\（1）.Visible=False‘Endsub

DimMyFile,MyPath,MyName‘subdir

'返回“WIN.INI〞（假使該文件存在）。

MyFile=Dir(\練習(xí)\\1.xls\

'返回帶指定擴展名的文件名。假使超過一個*.ini文件存在，'函數(shù)將返回按條件第一個找到的文件名。MyFile=Dir(\練習(xí)\\*.xls\

'若其次次調(diào)用Dir函數(shù)，但不帶任何參數(shù)，則函數(shù)將返回同一目錄下的下一個*.ini文件。MyFile=Dir

'返回找到的第一個隱式*.TXT文件。

MyFile=Dir(\‘endsubsubdir

MyPath=\練習(xí)\\\'sub指定路徑。

MyName=Dir(MyPath,vbDirectory)'找尋第一項。DoWhileMyName\開始循環(huán)。'跳過當前的目錄及上層目錄。

IfMyName\'使用位比較來確定MyName代表一目錄。

If(GetAttr(MyPath&MyName)AndvbDirectory)=vbDirectoryThenDebug.PrintMyName'假使它是一個目錄，將其名稱顯示出來。EndIfEndIf

MyName=Dir'查找下一個目錄。

Loop

DimaAsString‘subA列全名B列本名

Dimb(1000)AsString‘1000為允許的I的數(shù)量Dimc(1000)AsStringDimi,jAsIntegeri=0

a=dir(\練習(xí)\\*.*\Doc(i)=a

b(i)=\練習(xí)\\\Cells(i+1,2)=c(i)'2列Cells(i+1,1)=b(i)'1列i=i+1

a=dir'()'A走下一個LoopUntila=\

MsgBox\‘endsubsubA列全名B列本名

DimfnAsString‘subwhile全名寫入A列DimrAsLong

fn=Dir(\D:\\EXCEL練習(xí)\\*.xls\R=0

Whilefn\r=r+1Cells(r,1)=fnfn=Dir()Wend

MsgBox\‘endsubwhile全名寫入A列

DimMypathAsString'sub文件夾下一極所有找文件夾

DimMyfileAsString

Dimarr(1To1000,1To1)AsString

DimkAsInteger

Mypath=\練習(xí)\\\Myfile=dir(Mypath,vbDirectory)

DoWhileMyfile\

IfGetAttr(Mypath&Myfile)=vbDirectoryThen

k=k+1arr(k,1)=Myfile

EndIfMyfile=dir

Loop

Columns(\

Cells(1,1).Resize(UBound(arr),1)=arr'endsub文件夾下一極所有找文件夾

Dimfs,fold,fls,fl‘Sub2023vba開啟子文件()Setfs=CreateObject(\Setfold=fs.getfolder(\練習(xí)\\\‘能用Setfls=fold.FilesForEachflInfls

IfInStr(fl.Name,\Workbooks.Openfl.Path'開啟文件Sheets(1).Cells(2,5)=\

Workbooks(fl.Name).CloseSavechanges:=True'關(guān)閉文件

EndIfNext

MsgBox\‘endsubSub2023vba開啟子文件()DimnmAsString‘sub開啟文件最簡單代碼nm=dir(\練習(xí)\\\DoWhileLen(nm)0

Workbooks.Open(\練習(xí)\\\Sheets(1).Cells(2,5)=\Workbooks(nm).CloseSavechanges:=Truenm=dir()Loop

MsgBox\‘endsub打開文件最簡潔代碼DimiAsLong‘SubfileSearchVBA2003能用DimfsAsObject

Setfs=Application.FileSearchWithfs

.LookIn=\D:\\EXCEL練習(xí)\'設(shè)置要查找的起始目錄

.FileType=msoFileTypeExcelWorkbooks'要查找的文件類型.SearchSubFolders=True'是否查找子目錄.Execute'根據(jù)上面的設(shè)置執(zhí)行查找Fori=1To.FoundFiles.Count

Workbooks.Open.FoundFiles(i)'遍歷打開找到的EXCEL文件Nexti

EndWith‘EndSubfileSearchVBA2003能用

Dimp,f,sh‘sub打印所有本子

p=ThisWorkbook.Path&\'提取當前工作薄路徑f=Dir(p&\)'提取目錄指定文件類型為xlsDoWhilef\'假使文件F\IffThisWorkbook.NameThen'f當前工作薄名Workbooks.Open(p&f)'打開f

ForEachshInActiveWorkbook.Sheets'循環(huán)所有工作表

sh.PrintOut'打印工作表Nextsh

Workbooks(f).CloseFalse'閉卷當前f工作薄,false=不保存EndIf

f=Dir'提取一下文件名Loop

ForEachshInThisWorkbook.Sheets'循環(huán)完以后開始打印當前工作薄sh.PrintOut

Nextsh‘EndSub打印所有本子

SubMacro1()‘未試驗不知實用性

DimmyDialogAsFileDialog,oFileAsObject,strNameAsString,nAsIntegerDimFSOAsObject,myFolderAsObject,myFilesAsObject,Dimfn$SetmyDialog=Application.FileDialog(msoFileDialogFolderPicker)n=1

WithmyDialog

If.Show-1ThenExitSub

SetFSO=CreateObject(\這是文件夾選擇,點選到你存放文件的那個SetmyFolder=FSO.GetFolder(.InitialFileName)SetmyFiles=myFolder.Files

ForEachoFileInmyFiles

strName=UCase(oFile.Name)strName=VBA.Right(strName,3)IfstrName=\這是擴展名選擇'下面就可接著寫打開文件讀取數(shù)據(jù)再寫入的語句了,如下:fn=myFolder&\Workbooks.OpenFilename:=fn

Worksheets(1).Select'假設(shè)你讀取SHEET1的數(shù)據(jù)

RANGE_=Range(\需要數(shù)據(jù)的區(qū)域,自己修改

Windows(\外部表格數(shù)據(jù)自動導(dǎo)入.xls\這個是新表的文件名,自己修改下Worksheets(n).Select'打開第幾個文件就選擇SHEET幾,如果沒有可用ADD代碼添加Range(\寫入數(shù)據(jù)Workbooks(2).Closen=n+1EndIfNext

EndWith‘EndSub未實驗不知實用性

DimMypathAsString'sub輸出文件夾下一極所有找文件夾名，打開本級和下級所有文件DimMyfileAsStringDimnmAsString

Dimarr(1To1000,1To1)AsStringDimkAsInteger

Mypath=\練習(xí)\\\

Myfile=dir(Mypath,vbDirectory)

DoWhileMyfile\'開始循環(huán)。

IfGetAttr(Mypath&Myfile)=vbDirectoryThenk=k+1

arr(k,1)=Myfile

Setrrr=CreateObject(\Setr=rrr.GetFolder(Mypath&Myfile)

Application.ScreenUpdating=FalseForEachiInr.Files

Workbooks.Openfilename:=(Mypath&Myfile&\Sheets(1).Cells(2,5)=\ActiveWorkbook.Closesavechanges:=TrueNextEndIf

Myfile=dir'查找下一個目錄。

Loop

Columns(\

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

MsgBox\‘endsub輸出文件夾下一極所有找文件夾名，開啟本級和下級所有文件

VB+Dir

函數(shù)遞歸列出目錄所有文件，包含子目錄

PrivateSubEnumDir(ByValpathnameAsString)

DimpathsAsCollection'保存當前下的所有子目錄paths=NewCollection

IfRight$(pathname,1)\Thenpathname=pathname&\EndIf

DimfilenameAsString

filename=Dir(pathname,vbDirectory+vbSystem+vbHidden+vbReadOnly)DoWhilefilename\

Iffilename\Andfilename\Then'’跳過當前目錄和上層目錄If(GetAttr(pathname&filename)AndvbDirectory)=vbDirectoryThenpaths.Add(pathname&filename)'假使是目錄，則將目錄名添加到目錄集合，為遞歸做準備ElseList1.AddItem(filename)'將文件名添加到listboxEndIfEndIf

filename=Dir()Loop

DimiAsInteger

Fori=1Topaths.Count'遞歸子目錄EnumDir(paths(i))Next‘EndSub

返回一個String，用以表示一個文件名、目錄名或文件夾名稱，它必需與指定的模式或文件屬性、或磁盤卷標相匹配。語法

Dir[(pathname[,attributes])]Dir函數(shù)的語法具有以下幾個部分：

部分描述

pathname

可選參數(shù)。用來指定文件名的字符串表達式，可能包含目錄或文件夾、以及驅(qū)動器。假使沒有找到pathname，則會返回零長度字符串(\。

可選參數(shù)。常數(shù)或數(shù)值表達式，其總和用來指定文件屬性。假使省略，則會返回匹配pathname但不包含屬性的文件。

attributes

設(shè)置值

attributes參數(shù)的設(shè)置可為：

常數(shù)vbNormalvbReadOnlyvbHiddenVbSystemvbVolume

值01248

描述

(缺省)指定沒有屬性的文件。指定無屬性的只讀文件指定無屬性的隱蔽文件

指定無屬性的系統(tǒng)文件在Macintosh中不可用。

指定卷標文件；假使指定了其它屬性，則忽略vbVolume在Macintosh中不可用。

vbDirectoryvbAlias

1664

指定無屬性文件及其路徑和文件夾。指定的文件名是別名，只在Macintosh上可用。

注意這些常數(shù)是由VBA所指定的，在程序代碼中的任何位置，可以使用這些常數(shù)來替換真正的數(shù)值。說明

在MicrosoftWindows中，Dir支持多字符(*)和單字符(?)的通配符來指定多重文件。在Macintosh中，這些字符作為合法文件名字符并且不能作為通配符來指定多個文件為選中文件夾中所有文件，指定一空串:Dir(\

在MicrosoftWindows中，假使在Dir函數(shù)中使用MacID函數(shù)，將產(chǎn)生錯誤。任何大于256的attribute值都被認為是MacID函數(shù)的值。

在第一次調(diào)用Dir函數(shù)時，必需指定pathname，否則會產(chǎn)生錯誤。假使也指定了文件屬性，那么就必需包括pathname。

Dir會返回匹配pathname的第一個文件名。若想得到其它匹配pathname的文件名，再一次調(diào)用Dir，且不要使用參數(shù)。假使已沒有貼合條件的文件，則Dir會返回一個零長度字符串(\。一旦返回值為零長度字符串，并要再次調(diào)用Dir時，就必需指定pathname，否則會產(chǎn)生錯誤。不必訪問到所有匹配當前pathname的文件名，就可以改變到一個新的pathname上。但是，不能以遞歸方式來調(diào)用Dir函數(shù)。以vbDirectory屬性來調(diào)用Dir不能連續(xù)地返回子目錄。提醒由于文件名并不會以特別的次序來返回，所以可以將文件名存儲在一個數(shù)組中，然后再對這個數(shù)組排序。

本例如使用Dir函數(shù)來檢查某些文件或目錄是否存在。在Macintosh計算機上，默認驅(qū)動器名稱是“HD〞，并且路徑部分由冒號取代反斜線隔開。而且MicrosoftWindows的通配符在Mac中可以作為有效字符出現(xiàn)在文件名中。也可以使用MacID函數(shù)來指定文件組。DimMyFile,MyPath,MyName

'返回“WIN.INI〞(在MicrosoftWindows中)（假使該文件存在）。MyFile=Dir(\

'返回帶指定擴展名的文件名。假使超過一個*.ini文件存在，'函數(shù)將返回按條件第一個找到的文件名。MyFile=Dir(\

'若其次次調(diào)用Dir函數(shù)，但不帶任何參數(shù)，則函數(shù)將返回同一目錄下的下一個*.ini文件。MyFile=Dir

'返回找到的第一個隱式*.TXT文件。MyFile=Dir(\vbHidden)

'顯示C:\\目錄下的名稱。

MyPath=\指定路徑。

MyName=Dir(MyPath,vbDirectory)'找尋第一項。DoWhileMyName\開始循環(huán)。'跳過當前的目錄及上層目錄。

IfMyName\'使用位比較來確定MyName代表一目錄。

If(GetAttr(MyPath&MyName)AndvbDirectory)=vbDirectoryThenDebug.PrintMyName'假使它是一個目錄，將其名稱顯示出來。EndIfEndIf

MyName=Dir'查找下一個目錄。Loop

aa=2c=3x=2

DoWhileNotIsEmpty(Sheets(\x=x+1Loop

yc=x‘找CKJL第一個空行

DoWhileNotIsEmpty(Sheets(\‘名稱a=Sheets(\‘數(shù)量f=2，d=Sheets(\‘型號e=Sheets(\‘型號d1=Sheets(\‘名稱f1=Sheets(\‘名稱

DoWhiledeOrd1f1f=f+1

d=Sheets(\e=Sheets(\d1=Sheets(\

f1=Sheets(\

Loop‘在ZB中找CKD（C，3）名稱一致項

IfSheets(\bb=Sheets(\

Ifbb>=0Then

Sheets(\

Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\

Else:MsgBox\庫存量出錯\

EndIf

EndIf

IfSheets(\

Sheets(\s(f,1)當前名稱一致單元格

Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\Sheets(\aa=aa+1EndIf