作者：绿色风
分类：
时间：2022-08-17
浏览：143
楼主
kevinchengcw |
Q: 如何用vba代码建立指定文件夹最内层文件夹内文件列表及链接？
A: 代码如下：- Sub test()
- Dim FSO As Object, Txt, mPath$, Str$, Dic As Object, Arr, N&, I&
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- mPath = ThisWorkbook.Path '赋值路径变量（本例为当前工作簿所在目录）
- CreateObject("wscript.shell").Run "cmd.exe /c dir """ & mPath & "\*.*"" /ad/s/b>""" & mPath & "\list.txt""", 0, True '利用wscript执行命令行操作生成路径下的文件夹列表清单文件并等待执行完成
- Set FSO = CreateObject("scripting.filesystemobject") '创建FSO项目用于操作清单文件
- Set Txt = FSO.opentextfile(mPath & "\list.txt") '打开清单文件
- Do While Not Txt.atendofstream '循环清单文件内容
- Str = Txt.readline '读取一行数据
- If Trim(Str) <> "" Then '如果数据有效
- Dic.Add Str & "\", "" '添加路径到字典中
- If Dic.Count > 1 Then '如果字典项目达到两项以上
- Arr = Dic.keys '将字典keys赋值给数组
- For N = LBound(Arr) To UBound(Arr) - 1 '循环数组，进行替换测试，以确定当前项是否是另一循环中当前项的父路径，如果是则删除路径短者
- For I = N + 1 To UBound(Arr)
- If Len(Replace(Arr(I), Arr(N), "")) < Len(Arr(N)) Then Dic.Remove Arr(N)
- Next I
- Next N
- End If
- End If
- Loop
- Txt.Close '关闭清单文件
- Kill mPath & "\list.txt" '删除清单文件
- Arr = Dic.keys '提取字典的keys
- Dic.RemoveAll '清空字典内容
- I = 2 '设置单元格行数起始量
- For N = LBound(Arr) To UBound(Arr) '循环数组内容，列举出目录
- FN = Dir(Arr(N) & "*.*") '提取出对应路径下的文件清单
- Do While FN <> ""
- Cells(I, 1) = FN '将文件名写到对应A列单元格
- ActiveSheet.Hyperlinks.Add Cells(I, 2), Arr(N) & FN, "", Arr(N) & FN '在B列建立对应的超链接
- I = I + 1 '下移一行
- FN = Dir
- Loop
- Next N
- Set Txt = Nothing '清空各个项目
- Set FSO = Nothing
- Set Dic = Nothing
- End Sub
|
2楼
亡者天下 |
过来学习一下
 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一