List Files In Subfolders with Modified Date

[blimbert]

Hello - I am trying to obtain a file listing of all files in a network folder, and multiple layers of subfolders.

Requirements:

1. Return filename, file path, file type, and file last modified date to an excel sheet
2. Evaluate all files within all subfolders. In other words if there are nested subfolders, evaluate the files within every subfolder and its subfolders
3. Obtain the file information if the last modified date is after a certain date (eg >=1/1/2022)
4. Obtain the file information if the file type is a certain file type (eg .xlsx)

I have tried various code snippets from various sources and have not yet found one that works as desired.

Could you please help?

 

[Legacy 143009]

It's a working code. I've tested it in my company's network drive:

Dim r As Long
Sub loopAllSubFolderSelectStartDirectory()
  r = 2
  Call LoopAllSubFolders("\\server_name\all_users\documents\")
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
  Dim fileName As String
  Dim fullFilePath As String
  Dim numFolders As Long
  Dim folders() As String
  Dim i As Long
  

  Cells(1, 1).Value = "File Name"
  Cells(1, 2).Value = "File Path"
  Cells(1, 3).Value = "File Type"
  Cells(1, 4).Value = "Last Modified Date"
  
  
  If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
  fileName = Dir(folderPath & "*.*", vbDirectory)

  Do While fileName <> ""
    If Left(fileName, 1) <> "." Then
      fullFilePath = folderPath & fileName
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
          ReDim Preserve folders(0 To numFolders) As String
          folders(numFolders) = fullFilePath
          numFolders = numFolders + 1
        Else
          fullFilePath = folderPath & fileName
          If Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, ".")) = "xlsx" And Format(FileDateTime(fullFilePath), "dd/mm/yyyy") >= Format("1/1/2022", "dd/mm/yyyy") Then
            Cells(r, 1).Value = fileName
            Cells(r, 2).Value = fullFilePath
            Cells(r, 3).Value = Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, "."))
            Cells(r, 4).Value = Format(FileDateTime(fullFilePath), "dd/mm/yyyy")
            r = r + 1
          End If
        End If
    End If
    fileName = Dir()
  Loop

  For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
  Next i
End Sub

 

[blimbert]

It's a working code. I've tested it in my company's network drive:

Dim r As Long
Sub loopAllSubFolderSelectStartDirectory()
  r = 2
  Call LoopAllSubFolders("\\server_name\all_users\documents\")
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
  Dim fileName As String
  Dim fullFilePath As String
  Dim numFolders As Long
  Dim folders() As String
  Dim i As Long
 

  Cells(1, 1).Value = "File Name"
  Cells(1, 2).Value = "File Path"
  Cells(1, 3).Value = "File Type"
  Cells(1, 4).Value = "Last Modified Date"
 
 
  If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
  fileName = Dir(folderPath & "*.*", vbDirectory)

  Do While fileName <> ""
    If Left(fileName, 1) <> "." Then
      fullFilePath = folderPath & fileName
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
          ReDim Preserve folders(0 To numFolders) As String
          folders(numFolders) = fullFilePath
          numFolders = numFolders + 1
        Else
          fullFilePath = folderPath & fileName
          If Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, ".")) = "xlsx" And Format(FileDateTime(fullFilePath), "dd/mm/yyyy") >= Format("1/1/2022", "dd/mm/yyyy") Then
            Cells(r, 1).Value = fileName
            Cells(r, 2).Value = fullFilePath
            Cells(r, 3).Value = Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, "."))
            Cells(r, 4).Value = Format(FileDateTime(fullFilePath), "dd/mm/yyyy")
            r = r + 1
          End If
        End If
    End If
    fileName = Dir()
  Loop

  For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
  Next i
End Sub

Thank you so much for this code starter! I is exactly what I am looking for. While I can follow most of it there is a bug that I can't seem to crack. After a certain number of iterations it seems to "drop" a subfolder and returns error code 53, file not found. I added a debug.print statement to see what the fullFilePath variable was returning. Note the highlight in the immediate window shows a filepath that is different than the filepath of the windows explorer window. For the life of me I can't determine where this is bugging out in the code, could you please lend a hand?

 

[Legacy 143009]

Do you want the good news or bad news first?

Good news is, I found the cause. I came across the same problem coincidentally while testing again with another folder.
I have a file which was sent by our China factory. I think the characterset they are using and the way it is written on the hardrive are different. Check my case:

Pay attention to the pharantesis on these two files. They look similar but you'll notice that the phrantesis on the second file are odd. It is the problematic file.
VBA recognizes them as normal pharantesis but they are not in reality.



I took that file to the desktop and replaced the pharantesis with my keybord. Put it back to same folder again. Even windows allowed me to write the same file with the same name again!

Because their characterset are not the same actually.

Bad news is, I can not think of a work around about this. Maybe you can try something like

Name "C:\VBA Folder\Sample file 1.xlsx" As "C:\VBA Folder\Sample file 2.xlsx"

but I am not confident that it can rename a file which is not found.

Sorry but I have no idea. Good luck! And let me know if you can solve it

 

[blimbert]

Do you want the good news or bad news first?

Good news is, I found the cause. I came across the same problem coincidentally while testing again with another folder.
I have a file which was sent by our China factory. I think the characterset they are using and the way it is written on the hardrive are different. Check my case:
View attachment 81314

Pay attention to the pharantesis on these two files. They look similar but you'll notice that the phrantesis on the second file are odd. It is the problematic file.
VBA recognizes them as normal pharantesis but they are not in reality.



I took that file to the desktop and replaced the pharantesis with my keybord. Put it back to same folder again. Even windows allowed me to write the same file with the same name again!

Because their characterset are not the same actually.

Bad news is, I can not think of a work around about this. Maybe you can try something like

Name "C:\VBA Folder\Sample file 1.xlsx" As "C:\VBA Folder\Sample file 2.xlsx"

but I am not confident that it can rename a file which is not found.

Sorry but I have no idea. Good luck! And let me know if you can solve it

Thanks for your continued support on this topic. That is an interesting issue that you discovered. I don't think that is the issue in this instance, I'll try to explain why.

1. I used another set of VBA to print the text of everything in this particular folder where the issue was happening. I then ran that list of strings through another program to identify any non-Ascii texts, to which it did not yield any. So I **think** that list of files doesn't have the same issue that you experienced.
2. Can you take another look at this result from the debug statement I added to your code? It looks like there's some issue in the looping in that once the error starts happening, a subfolder gets "dropped" from the next line.
   1. All of these files are in the same folder, highlighted in the red box.
   2. Something happened in the looping such that the red box got "Dropped" from the filepath. See the green box, there's no red box after that. I think that's what triggers the file not found error, as it's not in the green folder, but it actually is listed in the red folder. But, the filepath variable was changed so it throws that error.
   3. Moving on to the next line now the green folder is dropped and the blue folder is what is showing.
   4. Moving on to the next line the blue folder is dropped, and so on.
   5. the confusing part is that all of these files are actually in the red directory, but something is changing the filepath so that it is returning the wrong thing.

So, I don't know what is causing it to throw this error, or how it's dropping the subfolder. I see nothing wrong ascii wise in the files before or after the error is thrown, listed here.

• 2010-10 RECON- Retail Resources - R1005993-OCT10 - (11-12-10).xlsx
• 2010-11 - Retail Resources - R1006451-NOV10 - (12-06-10).xlsx

I believe the error to be due to the subfolder getting dropped but I cannot figure out why.
Could you please help one more time? Thank you kindly

 

[Gokhan Aycan]

I wonder if using FileSystemObject and getting the matching files as a File Object to an array/collection/dictionary help.

 

[Gokhan Aycan]

Sorry edit time expired. Not related to above comment but I see you are writing every result in cells directly, and w/o a ScreenUpdating = False Depends on the number of matching files but how long does that take to run? Get the results into an array and range paste while having ScreenUpdating = False.

 

[Sufiyan97]

It's a working code. I've tested it in my company's network drive:

Dim r As Long
Sub loopAllSubFolderSelectStartDirectory()
  r = 2
  Call LoopAllSubFolders("\\server_name\all_users\documents\")
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
  Dim fileName As String
  Dim fullFilePath As String
  Dim numFolders As Long
  Dim folders() As String
  Dim i As Long
 

  Cells(1, 1).Value = "File Name"
  Cells(1, 2).Value = "File Path"
  Cells(1, 3).Value = "File Type"
  Cells(1, 4).Value = "Last Modified Date"
 
 
  If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
  fileName = Dir(folderPath & "*.*", vbDirectory)

  Do While fileName <> ""
    If Left(fileName, 1) <> "." Then
      fullFilePath = folderPath & fileName
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
          ReDim Preserve folders(0 To numFolders) As String
          folders(numFolders) = fullFilePath
          numFolders = numFolders + 1
        Else
          fullFilePath = folderPath & fileName
          If Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, ".")) = "xlsx" And Format(FileDateTime(fullFilePath), "dd/mm/yyyy") >= Format("1/1/2022", "dd/mm/yyyy") Then
            Cells(r, 1).Value = fileName
            Cells(r, 2).Value = fullFilePath
            Cells(r, 3).Value = Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, "."))
            Cells(r, 4).Value = Format(FileDateTime(fullFilePath), "dd/mm/yyyy")
            r = r + 1
          End If
        End If
    End If
    fileName = Dir()
  Loop

  For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
  Next i
End Sub

Hi Flashbond

How to make it to cover all the files, not excel only.
Can you please help.

 

[Legacy 143009]

Right(fullFilePath, Len(fullFilePath) - InStrRev(fullFilePath, ".")) = "xlsx" And

Removing this comdition should be enough.

 

[Sufiyan97]

Getting this error:

in this line