Im currently trying to edit a previously created Macro by another team It very successfully is able to retrieve all file names and paths from a specific location, very useful if all the files are there.
My issue is Im trying to adapt this to another area where the files are held in a "Storage" directory From here they go:
Storage\ProposalFolder\(1 of 3 folders)\File
the 1 of 3 folders thing helps sort them based on what type of proposal they are
Project, Prospect or Suspect
So what I need to do is have a macro thats given the Storage directory and then scans through each Proposal subfolder, then sees which folder type the file is stored in (if the file is in Project, the other 2 folders WILL be empty)
Please see below
Storage View
Proposal Folder
Project/prospect/suspect folder
This is the code left behind - I've edited it here and there
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
What I need to do is list the files in the subfolders just like the "For each objFile" code does, but I cant get my head around how to go further than one level of subfolders - the code commented out about subfolders was me :/
Any help would be super!
