VBA开启文件夹下所有文件

本文格式为Word版，下载可任意编辑——VBA开启文件夹下所有文件

‘subxlsOpen()

Setrrr=CreateObject(\Setr=rrr.GetFolder(\练习\\\

Application.ScreenUpdating=FalseForEachiInr.Files

Workbooks.OpenFilename:=(\练习\\\Sheets(1).Cells(2,5)=“10〞

ActiveWorkbook.Closesavechanges:=trueNext

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

ActiveWorkbook.Closesavechanges:=false‘不保存关闭ActiveWorkbook.Closesavechanges:=true‘保存关闭setrrr=CreateObject(\‘subSHEET,range

Setr=rrr.GetFolder(\练习\Application.ScreenUpdating=FalseForEachiInr.Files

Workbooks.OpenFilename:=(\练习\\\‘+=&Sheets(1).SelectRange(\

ActiveCell.FormulaR1C1=\

ActiveWorkbook.Closesavechanges:=true

Next

Application.ScreenUpdating=True‘EndSub

Dimwjm‘Subdir用法

wjm=Dir(\练习\\*.xls\MsgBoxwjm

DoWhilewjm\当指定路径中有文件时进行循环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=(\练习\\\‘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=(\练习\\\‘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=(\练习\\\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(\练习\\1.xls\

'返回带指定扩展名的文件名。假使超过一个*.ini文件存在，'函数将返回按条件第一个找到的文件名。MyFile=Dir(\练习\\*.xls\

'若其次次调用Dir函数，但不带任何参数，则函数将返回同一目录下的下一个*.ini文件。MyFile=Dir

'返回找到的第一个隐式*.TXT文件。

MyFile=Dir(\‘endsubsubdir

MyPath=\练习\\\'sub指定路径。

MyName=Dir(MyPath,vbDirectory)'找寻第一项。DoWhileMyName\开始循环。'跳过当前的目录及上层目录。

IfMyName\'使用位比较来确定MyName代表一目录。

If(GetAttr(MyPath&MyName)AndvbDirectory)=vbDirectoryThenDebug.PrintMyName'假使它是一个目录，将其名称显示出来。EndIfEndIf

MyName=Dir'查找下一个目录。

Loop

DimaAsString‘subA列全名B列本名

Dimb(1000)AsString‘1000为允许的I的数量Dimc(1000)AsStringDimi,jAsIntegeri=0

a=dir(\练习\\*.*\Doc(i)=a

b(i)=\练习\\\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练习\\*.xls\R=0

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

MsgBox\‘endsubwhile全名写入A列

DimMypathAsString'sub文件夹下一极所有找文件夹

DimMyfileAsString

Dimarr(1To1000,1To1)AsString

DimkAsInteger

Mypath=\练习\\\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(\练习\\\‘能用Setfls=fold.FilesForEachflInfls

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

Workbooks(fl.Name).CloseSavechanges:=True'关闭文件

EndIfNext

MsgBox\‘endsubSub2023vba开启子文件()DimnmAsString‘sub开启文件最简单代码nm=dir(\练习\\\DoWhileLen(nm)0

Workbooks.Open(\练习\\\Sheets(1).Cells(2,5)=\Workbooks(nm).CloseSavechanges:=Truenm=dir()Loop

MsgBox\‘endsub打开文件最简洁代码DimiAsLong‘SubfileSearchVBA2003能用DimfsAsObject

Setfs=Application.FileSearchWithfs

.LookIn=\D:\\EXCEL练习\'设置要查找的起始目录

.FileType=msoFileTypeExcelWorkbooks'要查找的文件类型.SearchSubFolders=True'是否查找子目录.Execute'根据上面的设置执行查找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'循环所有工作表

sh.PrintOut'打印工作表Nextsh

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

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

ForEachshInThisWorkbook.Sheets'循环完以后开始打印当前工作薄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=\这是扩展名选择'下面就可接着写打开文件读取数据再写入的语句了,如下:fn=myFolder&\Workbooks.OpenFilename:=fn

Worksheets(1).Select'假设你读取SHEET1的数据

RANGE_=Range(\需要数据的区域,自己修改

Windows(\外部表格数据自动导入.xls\这个是新表的文件名,自己修改下Worksheets(n).Select'打开第几个文件就选择SHEET几,如果没有可用ADD代码添加Range(\写入数据Workbooks(2).Closen=n+1EndIfNext

EndWith‘EndSub未实验不知实用性

DimMypathAsString'sub输出文件夹下一极所有找文件夹名，打开本级和下级所有文件DimMyfileAsStringDimnmAsString

Dimarr(1To1000,1To1)AsStringDimkAsInteger

Mypath=\练习\\\

Myfile=dir(Mypath,vbDirectory)

DoWhileMyfile\'开始循环。

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

函数递归列出目录所有文件，包含子目录

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函数的语法具有以下几个部分：

部分描述

pathname

可选参数。用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。假使没有找到pathname，则会返回零长度字符串(\。

可选参数。常数或数值表达式，其总和用来指定文件属性。假使省略，则会返回匹配pathname但不包含属性的文件。

attributes

设置值

attributes参数的设置可为：

常数vbNormalvbReadOnlyvbHiddenVbSystemvbVolume

值01248

描述

(缺省)指定没有属性的文件。指定无属性的只读文件指定无属性的隐蔽文件

指定无属性的系统文件在Macintosh中不可用。

指定卷标文件；假使指定了其它属性，则忽略vbVolume在Macintosh中不可用。

vbDirectoryvbAlias

1664

指定无属性文件及其路径和文件夹。指定的文件名是别名，只在Macintosh上可用。

注意这些常数是由VBA所指定的，在程序代码中的任何位置，可以使用这些常数来替换真正的数值。说明

在MicrosoftWindows中，Dir支持多字符(*)和单字符(?)的通配符来指定多重文件。在Macintosh中，这些字符作为合法文件名字符并且不能作为通配符来指定多个文件为选中文件夹中所有文件，指定一空串:Dir(\

在MicrosoftWindows中，假使在Dir函数中使用MacID函数，将产生错误。任何大于256的attribute值都被认为是MacID函数的值。

在第一次调用Dir函数时，必需指定pathname，否则会产生错误。假使也指定了文件属性，那么就必需包括pathname。

Dir会返回匹配pathname的第一个文件名。若想得到其它匹配pathname的文件名，再一次调用Dir，且不要使用参数。假使已没有贴合条件的文件，则Dir会返回一个零长度字符串(\。一旦返回值为零长度字符串，并要再次调用Dir时，就必需指定pathname，否则会产生错误。不必访问到所有匹配当前pathname的文件名，就可以改变到一个新的pathname上。但是，不能以递归方式来调用Dir函数。以vbDirectory属性来调用Dir不能连续地返回子目录。提醒由于文件名并不会以特别的次序来返回，所以可以将文件名存储在一个数组中，然后再对这个数组排序。

本例如使用Dir函数来检查某些文件或目录是否存在。在Macintosh计算机上，默认驱动器名称是“HD〞，并且路径部分由冒号取代反斜线隔开。而且MicrosoftWindows的通配符在Mac中可以作为有效字符出现在文件名中。也可以使用MacID函数来指定文件组。DimMyFile,MyPath,MyName

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

'返回带指定扩展名的文件名。假使超过一个*.ini文件存在，'函数将返回按条件第一个找到的文件名。MyFile=Dir(\

'若其次次调用Dir函数，但不带任何参数，则函数将返回同一目录下的下一个*.ini文件。MyFile=Dir

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

'显示C:\\目录下的名称。

MyPath=\指定路径。

MyName=Dir(MyPath,vbDirectory)'找寻第一项。DoWhileMyName\开始循环。'跳过当前的目录及上层目录。

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(\‘数量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