我目前正在尝试编辑另一个团队以前创建的宏它非常成功地能够从特定位置检索所有文件名和路径，如果所有文件都在那里，这非常有用。
我的问题是我试图将其调整到文件保存在“存储”目录中的另一个区域从这里开始：
Storage\ProposalFolder\（3 个文件夹中的 1 个）\File
3 个文件夹中的 1 个有助于根据它们的提案类型对它们进行排序
项目、前景或嫌疑人
所以我需要做的是有一个给定存储目录的宏，然后扫描每个提案子文件夹，然后查看文件存储在哪个文件夹类型中（如果文件在项目中，其他 2 个文件夹将为空）
请看下面
存储视图
提案文件夹
项目/前景/可疑文件夹
这是留下的代码 - 我在这里和那里编辑过
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
我需要做的是列出子文件夹中的文件，就像“对于每个 objFile”代码所做的那样，但我无法理解如何进一步超越一级子文件夹 - 注释掉子文件夹的代码是我：/
任何帮助都会很棒！