vba - 搜索目录中的文件并列出其名称和路径 - 两层子文件夹

Question

我目前正在尝试编辑另一个团队之前创建的宏它非常成功地能够从特定位置检索所有文件名和路径，如果所有文件都在那里，则非常有用。

我的问题是我试图将其适应另一个区域，其中文件保存在“存储”目录中从这里开始:

存储\ProposalFolder\(3 个文件夹之一)\文件

3 个文件夹中的 1 个可帮助根据提案类型对它们进行排序

项目、前景或怀疑

所以我需要做的是有一个给定存储目录的宏，然后扫描每个提案子文件夹，然后查看文件存储在哪个文件夹类型中(如果文件位于项目中，则其他 2 个文件夹将是空)

请看下面

存储 View

提案文件夹

项目/潜在客户/可疑文件夹

这是留下的代码 - 我已经在这里和那里编辑了它

Sub ListFilesInDirectory()

If MsgBox("Are you sure you want to list the files?", vbYesNo) = vbNo Then
End
Else
End If

Select Case MsgBox("Press Yes to retrieve ALL files." & vbNewLine & vbNewLine & "Press No to retrieve *** files only", vbQuestion + vbYesNoCancel + vbDefaultButton1, "Which Do You Want To Retrieve?")
Case vbCancel
End
Case vbNo
***_Option = 1
Case vbYes
***_Option = 2
End Select


Dim counter As Single
counter = Timer

On Error GoTo error_message
Application.StatusBar = "The macro is running. Please wait..."


Application.Calculation = xlCalculationManual
Range("A7:KZ10000").Select
Selection.ClearContents
Cells.FormatConditions.Delete
Range("A1").Select
Application.ScreenUpdating = False


'Populate columns A to C
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet
    Dim objSubfolders As Object

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = ActiveSheet

    startrow = 7


    If IsEmpty(Range("file_directory")) Then
        GoTo skip_this
        Else
        filedir = Range("file_directory").Value
    End If


    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder(filedir)
    Set objSubfolders = objFolder.subfolders
    'ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"

     'Loop through the Files collection
    If ***_Option = 1 Then
     For Each objFile In objFolder.Files
     DoEvents

      If InStr(UCase(objFile.Name), "****") > 0 Then
        ws.Cells(startrow, 1).Value = filedir
'        ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
        ws.Cells(startrow, 2).Value = objFile.Name
        ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name

        ws.Cells(startrow, 3).Value = objFile.DateLastModified
        startrow = startrow + 1
      End If
     Next
    End If

    If ***_Option = 2 Then
    For Each objFile In objFolder.Files
     DoEvents
        ws.Cells(startrow, 1).Value = filedir
'        ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
        ws.Cells(startrow, 2).Value = objFile.Name
        ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
        ws.Cells(startrow, 3).Formula = "=CONCATENATE(" & startrow & "2," & startrow & "3)"
        startrow = startrow + 1
     Next

'    For Each SubFolder In objSubfolders
'
'     For Each objFile In objSubfolders.Files
'     DoEvents
'        ws.Cells(startrow, 1).Value = filedir
''        ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
'        ws.Cells(startrow, 2).Value = objFile.Name
'        ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
'        ws.Cells(startrow, 3).Value = objFile.DateLastModified
'        startrow = startrow + 1
'     Next
'    Next SubFolder
    End If


'        For Each SubFolder In SourceFolder.subfolders
'            ListFilesInFolder SubFolder.Path, True
'        Next SubFolder
'
'    If subfolders = True Then
'        For Each SubFolder In SourceFolder.subfolders
'            ListFilesInFolder SubFolder.Path, True
'        Next SubFolder
'    End If

skip_this:
  Next

    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

    lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

'Format any potential error files in red
    Cells.FormatConditions.Delete
    Range("B7:B" & lastrow).Select

    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=RIGHT(B7,5)<>"".xlsm"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=LEFT(B7,1)=""~"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = True


'Range("C4").Select
'ActiveCell.FormulaR1C1 = "Date" & Chr(10) & "Modified"

Range("C7:C" & lastrow).Select
Selection.NumberFormat = "dd/mm/yyyy  hh:mm:ss"
Selection.HorizontalAlignment = xlCenter

Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False

MsgBox ("Time taken to list files (hr:min:sec): " & Format((Timer - counter) / 86400, "hh:mm:ss") & vbNewLine & vbNewLine & "Please now do an initial cleanup of the files listed:" & vbNewLine & "  1) Delete any obvious older versions of the files" & vbNewLine & "  2) Files highlighted red are likely to be incorrect and should be deleted")

Exit Sub
error_message:
If Err.Number <> 0 Then
     Msg = "Error # " & Str(Err.Number) & " was generated by " _
         & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
     MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
     End If
Range("A7:KZ10000").Select
Selection.ClearContents
Cells.FormatConditions.Delete
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox ("You have entered an incorrect directory path. Please ensure the 3 cells in the Variables tab are showing valid directory paths, or the cells are empty")
End Sub

我需要做的是列出子文件夹中的文件，就像“For every objFile”代码所做的那样，但我无法理解如何进一步超出一级子文件夹 - 关于子文件夹的注释代码是我:/

任何帮助都会非常好!

Answer 1

对上面的评论进行进一步...

递归过程通常通过调用自身重复进入“较低级别”。显然，如果编码不正确，这可能会导致问题，但此网站和其他网站上有无数的代码示例，例如:

• 堆栈溢出:List all files in a folder and subfolders in excel
• 堆栈溢出:Loop through files in a folder using VBA?
• 堆栈溢出:get list of subdirs in vba
• 堆栈溢出:List files in folder and subfolder with path to .txt file
• 艾伦·布朗:List files recursively
• 奇普· PIL 森:Recursion And The FileSystemObject
• 维基百科:Recursion in Computer Science

您需要了解的所有内容都包含在这些页面中(或链接自这些页面)。