vba获得最后子文件夹路径

❶ VB查找指定文件夹并获取文件路径的代码

1.首先打开来Excel电子表格，然自后在开发工具中打开VBA编辑器，如下图。

❷ 如何通过VBA，获得本文件所在的文件夹路径。

Subs()
Dimpth$
pth=ThisWorkbook.Path
MsgBox"本文件的路径为："&pth
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

❹ EXCEL VBA 获取文件夹及子文件夹下所有文件并建立超链接

可以用代码完成：
1、先编制表格：
2、在表格里编写触发宏代码：
private
sub
worksheet_change(byval
target
as
range)
dim
photoname
as
string
if
target.row
=
3
and
target.column
>
3
and
target.column
<
6
then
on
error
resume
next
'忽略错误继续执行vba代码,避免出现错误消息
application.screenupdating
=
false
application.enableevents
=
false
for
each
shp
in
sheets("查询表").shapes
if
shp.type
<>
8
and
shp.type
<>
12
then
shp.delete
end
if
next
photoname
=
cells(3,
4)
&
".jpg"
cells(3,
"l").select
activesheet.pictures.insert(activeworkbook.path
&
"\照片\"
&
photoname).select
'当前文件所在目录下以单元内容为名称的.jpg图片
with
selection
ta
=
range(cells(3,
"l").mergearea.address).height
'单元高度
tb
=
range(cells(3,
"l").mergearea.address).width
'单元宽度
tc
=
.height
'图片高度
td
=
.width
'图片宽度
tm
=
application.worksheetfunction.min(ta
/
tc,
tb
/
td)
'单元与图片之间长宽差异比例的最小值
.top
=
activecell.top
+
2
.left
=
activecell.left
+
1
.height
=
.height
*
tm
*
0.98
'按比例调整图片宽度
.width
=
.width
*
tm
*
0.98
'按比例调整图片高度
end
with
cells(3,
4).select
application.enableevents
=
true
application.screenupdating
=
true
end
sub
3、在当前目录下建个名为”照片“的子目录，里面存有以姓名为名称的.jpg格式的照片
4、在姓名后单元输入姓名后，就能自动插入图片了

❺ VBA中怎么遍历所选路径中所有文件夹及其子文件夹(多个子文件)，并返回所有的最底层的文件夹路径

答：执行"获取所有文件夹"，按提示操作。文件夹清单会显示在工作表的AB列中。

Sub获取所有文件夹()
DimDirectoryAsString
WithApplication.FileDialog(msoFileDialogFolderPicker)
.InitialFileName=Application.DefaultFilePath&""
.Title="请选择一个文件夹"
.Show
If.SelectedItems.Count=0Then
ExitSub
Else
Directory=.SelectedItems(1)
EndIf
EndWith
Cells.ClearContents
CallRecursiveDir(Directory)
EndSub
PublicSubRecursiveDir(ByValCurrDirAsString)
DimDirs()AsString
DimNumDirsAsLong
DimFilesizeAsDouble
DimTotalFolders,SingleFolder
Cells(1,1)="目录名"
Cells(1,2)="日期/时间"
Range("A1:B1").Font.Bold=True

SetTotalFolders=CreateObject("Scripting.FileSystemObject").GetFolder(CurrDir).SubFolders
Cells(WorksheetFunction.CountA(Range("A:A"))+1,1)=CurrDir
Cells(WorksheetFunction.CountA(Range("B:B"))+1,2)=FileDateTime(CurrDir)
IfTotalFolders.Count<>0Then

ReDimPreserveDirs(0ToNumDirs)AsString
Dirs(NumDirs)=SingleFolder
NumDirs=NumDirs+1
Next
EndIf
Fori=0ToNumDirs-1
RecursiveDirDirs(i)
Nexti
EndSub