【vba】分享一个Excel写的源码，提取文件夹中所有文件、文件夹名称。

cheshirekitten

功能介绍：
提取文件夹中所有文件、文件夹名称及所在地址
使用步骤，如图：
操作01：窗口界面

操作02：点开界面

操作03：提取地址生成文件

操作04：点开-文件名已提取


窗口界面代码如图：



论坛插入用的vb语言，代码分为两部分，如下：

[Visual Basic] 纯文本查看 复制代码

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

lkfcsp1314

不知道是不会用还是有问题，提取不了文件夹

alex0416

试试这个。应该是可以的。
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

lzspain

请教一个问题，以下是清除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

付国兵123

不行啊，加载文件夹后一点反应都没有，用的是Excel 2007

atxz

感谢分享  支持一下

daqing88

感谢分享，先收藏

wanderrr

clash该升级了

atpjcom

谢谢你的分享！

hlw2008

就服VBA，

zhlezhi

代码使用了不行啊，无法使用，提示缺少end sub ，楼主传少了吧