【vba】分享一个Excel写的源码，提取文件夹中所有文件、文件夹名称。
本帖最后由 cheshirekitten 于 2022-6-9 12:43 编辑功能介绍：
提取文件夹中所有文件、文件夹名称及所在地址
使用步骤，如图：
操作01：窗口界面
操作02：点开界面
操作03：提取地址生成文件
操作04：点开-文件名已提取
窗口界面代码如图：
论坛插入用的vb语言，代码分为两部分，如下：
Sub FSO_FileExtraction()
Dim strFldPath As String '定义文件夹路径变量
With Application.FileDialog(msoFileDialogFolderPicker) '用户选择指定文件夹
.Title = "请选择指定文件夹。"
If .Show Then
strFldPath = .SelectedItems(1)
Else
Exit Sub '如果用户没有指定文件夹，则退出程序
End If
End With
Application.ScreenUpdating = False '关闭屏幕刷新
Range("a:b").ClearContents
Range("a1:b1") = Array("文件夹", "文件名及超链接")
Call ExtractionFileAddHyperlinks(strFldPath) '调取文件提取及增加超链接的函数
Range("a:b").EntireColumn.AutoFit '自动列宽
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
ActiveSheet.Shapes.Range(Array("Button 1")).Delete
ActiveWorkbook.SaveAs Filename:= _
strFldPath & "\文档目录.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Application.ScreenUpdating = True '打开屏幕刷新
Range("a:c").ClearContents
Columns("A:C").ColumnWidth = 8.08
ThisWorkbook.Save
End Sub
----------------------------------------
Sub 文件提取()
'子函数
'ExtractionFileAddHyperlinks 如下图所示:
Function ExtractionFileAddHyperlinks(ByVal strFldPath As String) As String
Dim objMyFSO As Object '定义变量
Dim objFld As Object
Dim objFile As Object
Dim objSubFld As Object
Dim strFilePath As String
Dim lngLastRow As Long
Dim intNum As Integer
Set objMyFSO = CreateObject("Scripting.FileSystemObject") '用直接创建法 创建FSO对象
Set objFld = objMyFSO.GetFolder(strFldPath) '调用FSO的GetFolder方法
For Each objFile In objFld.Files '遍历文件夹内的文件
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
strFilePath = objFile.Path
intNum = InStrRev(strFilePath, "\") '使用instrrev函数获取最后文件夹名截至的位置
Cells(lngLastRow, 2) = Left(strFilePath, intNum - 1) '获取文件夹绝对地址
Cells(lngLastRow, 1) = Mid(strFilePath, intNum + 1) '获取文件名
' Cells(lngLastRow, 3) = "文件链接"
' ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngLastRow, 3), Address:=strFilePath, ScreenTip:=strFilePath '增加超链接
Next objFile
For Each objSubFld In objFld.SubFolders '遍历文件夹内的子文件夹
Call ExtractionFileAddHyperlinks(objSubFld.Path) '递归调用
Next objSubFld
Set objMyFSO = Nothing '清空对象变量
Set objFld = Nothing
Set objFile = Nothing
Set objSubFld = Nothing
End Function
不知道是不会用还是有问题，提取不了文件夹 本帖最后由 alex0416 于 2022-7-22 14:38 编辑
试试这个。应该是可以的。
Sub Main()
Dim Fso As Object, sFileType$, i&, arrf$(), m&
Dim sh As Object, myfld As Object
Dim Pt As String
Dim wkb As workbook
Dim wkst As worksheet
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = CreateObject("shell.application")
Set myfld = sh.BrowseForFolder(0, "打开文件夹", 0, "")
'打开对话框
If myfld Is Nothing Then Exit Sub '如果没有选择路径则退出
Pt = myfld.Items.Item.PATH '获得选择的路径
Set myfld = Nothing
Set sh = Nothing
Set Fso = CreateObject("Scripting.FileSystemObject")
sFileType = "*.xls"
Call GetFiles(Pt, sFileType, Fso, arrf, m) '取得文件夹及子文件夹所有的文件
For i = 1 To m
Set wkb = Application.Workbooks.Open(arrf(i))
wkb.Activate
For Each wkst In Sheets
wkst.Activate
With wkst.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
Next
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "删除完成", vbInformation, "提示"
End Sub
Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arr$(), ByRef m&)
Dim SubFolder As Object
Dim File As Object
For Each File In Fso.GetFolder(sPath).Files
If File.Name Like sFileType Then
If File.Name <> ThisWorkbook.Name Then
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = File
End If
End If
Next
For Each SubFolder In Fso.GetFolder(sPath).SubFolders '遍历Folder集合，统计出共有多少个文件夹，及相关文件夹的名字
Call GetFiles(SubFolder.PATH, sFileType, Fso, arr, m)
Next
Set File = Nothing
Set SubFolder = Nothing
End Sub 请教一个问题，以下是清除Excel工作簿页眉页脚的VBA代码，但是只对此表格所在文件夹内的表格有效，不能作用于子文件夹，要如何实现呢？
Sub DeleteHeader()
Dim wkb As Workbook
Dim wkst As Worksheet
Dim myPath$, myFile$
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
Set wkb = Application.Workbooks.Open(myPath & myFile)
wkb.Activate
For Each wkst In Sheets
wkst.Activate
With wkst.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
Next
wkb.Close True
End If
myFile = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "删除完成", vbInformation, "提示"
End Sub 不行啊，加载文件夹后一点反应都没有，用的是Excel 2007 感谢分享支持一下 感谢分享，先收藏 clash该升级了 谢谢你的分享！ 就服VBA， 代码使用了不行啊，无法使用，提示缺少end sub ，楼主传少了吧