vbadir子文件夹
① 如何用VBA遍历指定目录下的所有子文件夹Excel文件的所有工作表
vba麻烦点，dir最快，excelhome论坛上有大量现成代码：
SubOpiona()'//函数实例
FileArr=FileAllArr(ThisWorkbook.Path,"*.xls",ThisWorkbook.Name,False)
Fori=0ToUBound(FileArr)
MsgBoxFileArr(i)
'SetWB=Workbooks.Open(FileArr(I))'//打开工作簿
'你的代码
'WB.Closetrue'//保存
Next
EndSub
'*******************************************************************************************************
'功能：查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
'函数名：FileAllArr
'参数1：Filename需查找的文件夹名不含最后的""
'参数2：FileFilter需要过滤的文件名，可省略，默认为：[*.*]
'参数3：Liwai剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
'参数4：Files是否只要文件夹名，可省略，默认为：FALSE
'返回值：一个字符型的数组
'使用方法：FileArr=FileAllArr(ThisWorkbook.Path,"*.xls",ThisWorkbook.Name,false)
'作者:北极狐工作室QQ：14885553
'*******************************************************************************************************
PublicFunctionFileAllArr(ByValFilenameAsString,="*.*",OptionalByValLiwaiAsString="",OptionalByValFilesAsBoolean=False)AsString()
SetDic=CreateObject("Scripting.Dictionary")'创建一个字典对象
SetDid=CreateObject("Scripting.Dictionary")
Dic.Add(Filename&""),""
i=0
DoWhilei<Dic.Count
Ke=Dic.keys'开始遍历字典
MyName=Dir(Ke(i),vbDirectory)'查找目录
DoWhileMyName<>""
IfMyName<>"."AndMyName<>".."Then
If(GetAttr(Ke(i)&MyName)AndvbDirectory)=vbDirectoryThen'如果是次级目录
Dic.Add(Ke(i)&MyName&""),""'就往字典中添加这个次级目录名作为一个条目
EndIf
EndIf
MyName=Dir'继续遍历寻找
Loop
i=i+1
Loop
Dimarrx()AsString
i=0
IfFiles=TrueThen'//是否只输出文件夹名
ForEachKeInDic.keys'以查找总表所在文件夹下所有excel文件为例
ReDimPreservearrx(i)
IfKe<>Filename&""Then'//自身文件夹除外
arrx(i)=Ke
i=i+1
EndIf
Next
FileAllArr=arrx
Else
ForEachKeInDic.keys'以查找总表所在文件夹下所有excel文件为例
MyFileName=Dir(Ke&FileFilter)'过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
DoWhileMyFileName<>""
IfMyFileName<>LiwaiThen'排除例外文件
ReDimPreservearrx(i)
arrx(i)=Ke&MyFileName
i=i+1
EndIf
MyFileName=Dir
Loop
Next
FileAllArr=arrx
EndIf
EndFunction
'****************************************************************
② 怎样用vba取得子文件夹一览
用DIR这个函数来列出某个文件夹下的内容,
以excel里的为例
Dim i As Integer
i = 1
Sheet1.Range("A" & i) = Dir("C:\")
Do While True
i = i + 1
Sheet1.Range("A" & i) = Dir
If Sheet1.Range("A" & i) = "" Then Exit Do
Loop
③ 如何用vba遍历文件夹里面的子文件并且复制指定数据形成一张新的表格，ps：子文件的数据格式一直
尝试用下边代码试试：
Sub OpenAndClose()
Dim MyFile As String
Dim s As String
Dim count As Integer
MyFile = Dir(文件夹目录 & "*.xlsx")
'读入文件夹中的第一个.xlsx文件
count = count + 1 '记录文件的个数
s = s & count & "、" & MyFile
Do While MyFile <> ""
MyFile = Dir '第二次读入的时候不用写参数
If MyFile = "" Then
Exit Do '当MyFile为空的时候就说明已经遍历完了，这时退出Do，否则还要运行一遍
End If
count = count + 1
If count Mod 2 <> 1 Then
s = s & vbTab & count & "、" & MyFile
Else
s = s & vbCrLf & count & "、" & MyFile
End If
Loop
Debug.Print s
End Sub
另外，可以考虑用python试试
④ 用VBA代码如何获得指定文件夹内的所有子文件夹名称
Set fso=CreateObject("Scripting.FileSystemObject")
Set folder=fso.GetFolder("D:")
dim a() as string
dim b
b=1
for each thing in folder.subfolders
addfolder fso,thing,a,b
next
msgbox b
function addfolder(byref fso,byref dir,byref a,byref b)
set folder=fso.getfolder(dir)
a(b)=dir
b=b+1
For Each thing in folder.SubFolders
set folder=fso.getfolder(thing)
a(b)=thing
b=b+1
addfolder fso,thing,a,b
Next
end function
⑤ 在VBA中用Dir历遍包含子文件夹的所有文件，指定文件类型后就不历遍子文件夹了。请大神之招。代码如下：
SubScearchFiles_AndSub()
Dimx%,i%
WithApplication.FileDialog(msoFileDialogFolderPicker)
If.Show=-1Then
P=.SelectedItems(1)
IfRight(P,1)=""ThenP=PElseP=P&""
EndIf
EndWith
'------------------------------------------------------------------------------
SetFolderList=CreateObject("Scripting.Dictionary")
FolderList.AddP,""
i=0
DoWhilei<FolderList.Count
Ke=FolderList.Keys
'FName=Dir(FolderName,vbDirectory+vbHidden+vbNormal)
FName=Dir(Ke(i),vbDirectory)
DoWhileFName<>""
IfFName<>".."AndFName<>"."Then
IfGetAttr(Ke(i)&FName)AndvbDirectoryThen
FolderList.Add(Ke(i)&FName&""),""
EndIf
EndIf
FName=Dir
Loop
i=i+1
Loop
'------------------------------------------------------------------------------
ForEachFnInFolderList.Keys
FName=Dir(Fn&"*.pdf")
DoWhileFName<>""
Cells(x+1,1)=FName
x=x+1
FName=Dir
Loop
Next
EndSub
⑥ EXCEL VBA Dir 函数
这是文件系统发回给DIr的，一个点代表的是本级目录，两个点代表的是上级目录。他们以“文件”的方式保存在这个子文件夹的文件表里面用以保存自身的存放位置和与上级目录的关联
你需要自行鉴别获得的数据（包括可能的子文件夹）
⑦ 在VBA中用DIR函数遍历子文件夹出错
图片弹出的意思是：无效的过程调用。
dir是vba内置函数，需要参数运行。
⑧ Excel VBA列出某文件夹下子文件夹及文件名
遍历文件夹 并列出文件 & 文件夹 名 代码如下：
在文件夹内 新建 个 Excel文件
Excel文件内 按 Alt+F11 视图--代码窗口， 把如下代码复制进去， F5运行
Sub遍历文件夹()
'OnErrorResumeNext
Dimfn(1To10000)AsString
Dimf,i,k,f2,f3,x
Dimarr1(1To100000,1To1)AsString,qAsInteger
Dimt
t=Timer
fn(1)=ThisWorkbook.path&""
i=1:k=1
DoWhilei<UBound(fn)
Iffn(i)=""ThenExitDo
f=Dir(fn(i),vbDirectory)
Do
IfInStr(f,".")=0Andf<>""Then
k=k+1
fn(k)=fn(i)&f&""
EndIf
f=Dir
LoopUntilf=""
i=i+1
Loop
'*******下面是提取各个文件夹的文件***
Forx=1ToUBound(fn)
Iffn(x)=""ThenExitFor
f3=Dir(fn(x)&"*.*")
DoWhilef3<>""
q=q+1
arr1(q,1)=fn(x)&f3
f3=Dir
Loop
Nextx
ActiveSheet.UsedRange=""
Range("a1").Resize(q)=arr1
MsgBoxFormat(Timer-t,"0.00000")
EndSub
效果如图：
⑨ 如何用VBA遍历指定目录下的所有子文件夹和文件
SubTest()
DimMyName,Dic,Did,I,T,F,TT,MyFileName
T=Time
SetDic=CreateObject("Scripting.Dictionary")'创建一个字典对象
SetDid=CreateObject("Scripting.Dictionary")
Dic.Add("D:MyDocuments"),""
I=0
DoWhileI<Dic.Count
Ke=Dic.keys'开始遍历字典
MyName=Dir(Ke(I),vbDirectory)'查找目录
DoWhileMyName<>""
IfMyName<>"."AndMyName<>".."Then
If(GetAttr(Ke(I)&MyName)AndvbDirectory)=vbDirectoryThen'如果是次级目录
Dic.Add(Ke(I)&MyName&""),""'就往字典中添加这个次级目录名作为一个条目
EndIf
EndIf
MyName=Dir'继续遍历寻找
Loop
I=I+1
Loop
Did.Add("文件清单"),""'以查找D盘MyDocuments下所有EXCEL文件为例
ForEachKeInDic.keys
MyFileName=Dir(Ke&"*.xls")
DoWhileMyFileName<>""
Did.Add(Ke&MyFileName),""
MyFileName=Dir
Loop
Next
ForEachShInThisWorkbook.Worksheets
IfSh.Name="XLS文件清单"Then
Sheets("XLS文件清单").Cells.Delete
F=True
ExitFor
Else
F=False
EndIf
Next
IfNotFThen
Sheets.Add.Name="XLS文件清单"
EndIf
Sheets("XLS文件清单").[A1].Resize(Did.Count,1)=WorksheetFunction.Transpose(Did.keys)
TT=Time-T
MsgBoxMinute(TT)&"分"&Second(TT)&"秒"
EndSub
⑩ 如何用VBA复制整个文件夹包括子目录
Sub Files(Path As String, afterPath)
'Path：原文件夹路径；afterPath：目标文件夹路径
Dim Spath As String
Set fs = CreateObject("Scripting.FileSystemObject")
Spath = Dir(Path, vbDirectory)
Do While Len(Spath)
If Spath <> "." And Spath <> ".." Then
fs.CopyFolder Path, afterPath
Spath = Dir()
End If
Loop
End Sub
————————————————
版权声明：本文为CSDN博主“前端小菜鸟007”的原创文章，遵循CC 4.0 BY-SA版权协议，转载请附上原文出处链接及本声明。
原文链接：https://blog.csdn.net/weixin_41844140/article/details/103188537