Macro to open up files in sub folder that have the lastest modified date as well as those 60 days before that date

[howard]

I have code to open all files in the sub-folder of "\\MTR\Sales" that contain import data and have a .xlsm extension that are either latest modified filed or up to 60 days before todays date

The code up up some of these workbooks but not all of theem

It would be appreciated if someone could amend my code so all these .xlsm files that have text import template with the latest modified date or up to 60 days before todays date

 Sub Open_ImportTemplates()
    Dim FolderPath As String
    Dim ws As Worksheet
    Dim fso As Object
    Dim startDate As Date
    Dim endDate As Date
    Dim lastRow As Long
    Dim latestDate As Date
    Dim latestModifiedDate As Date
    Dim latestDateFile As Object
    Dim latestModifiedDateFile As Object
   
    FolderPath = "\\MTR\Sales" ' Specify the main folder path
   
    ' Set the worksheet to import the file names and modified dates
    Set ws = ThisWorkbook.Sheets("Import Templates")
   
    ' Clear existing data in column A
    ws.Range("A2:A" & ws.Rows.Count).ClearContents
   
    ' Create a FileSystemObject to work with folders and files
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    ' Calculate the start date and end date
    startDate = Date - 60
    endDate = Date
   
    ' Find the last used row in column A
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
   
    ' Start searching in the main folder and its subfolders
    RecursiveFileSearch FolderPath, ws, fso, startDate, endDate, lastRow, latestDate, latestModifiedDate, latestDateFile, latestModifiedDateFile
   
    ' Open the files with the latest date and latest modified date
    If Not latestDateFile Is Nothing Then
        Workbooks.Open latestDateFile.Path
    End If
    If Not latestModifiedDateFile Is Nothing Then
        Workbooks.Open latestModifiedDateFile.Path
    End If
   
    ' Release the FileSystemObject
    Set fso = Nothing
   
    DeleteRowsStartingWithTilde
    RemoveTime
End Sub

Sub RecursiveFileSearch(ByVal FolderPath As String, ByRef ws As Worksheet, ByRef fso As Object, ByVal startDate As Date, ByVal endDate As Date, ByRef lastRow As Long, ByRef latestDate As Date, ByRef latestModifiedDate As Date, ByRef latestDateFile As Object, ByRef latestModifiedDateFile As Object)
    Dim file As Object
    Dim SubFolder As Object
   
    ' Check if the folder exists
    If fso.FolderExists(FolderPath) Then
        ' Loop through all files in the folder
        For Each file In fso.GetFolder(FolderPath).Files
            ' Check if the file name contains the text "Import Template" and was last modified within the specified date range
            If InStr(1, LCase(file.Name), "import template") > 0 And file.DateLastModified >= startDate And file.DateLastModified <= endDate Then
                ' Check if the file has the latest date
                If file.DateLastModified > latestModifiedDate Then
                    latestModifiedDate = file.DateLastModified
                    Set latestModifiedDateFile = file
                End If
               
                ' Check if the file has the latest modified date
                Dim fileDate As Date
                If TryParseDateFromFileName(file.Name, fileDate) Then
                    If fileDate > latestDate Then
                        latestDate = fileDate
                        Set latestDateFile = file
                    End If
                End If
               
                ' Paste the file name in column A
                ws.Cells(lastRow, 1).Value = file.Name
                lastRow = lastRow + 1
            End If
        Next file
       
        ' Recursively search in subfolders
        For Each SubFolder In fso.GetFolder(FolderPath).Subfolders
            RecursiveFileSearch SubFolder.Path, ws, fso, startDate, endDate, lastRow, latestDate, latestModifiedDate, latestDateFile, latestModifiedDateFile
        Next SubFolder
    End If
End Sub

Function TryParseDateFromFileName(ByVal fileName As String, ByRef fileDate As Date) As Boolean
    Dim parts() As String
    parts = Split(fileName, " ")
    Dim i As Long
    For i = 0 To UBound(parts)
        If IsDate(parts(i)) Then
            fileDate = CDate(parts(i))
            TryParseDateFromFileName = True
            Exit Function
        End If
    Next i
    TryParseDateFromFileName = False
End Function

Sub DeleteRowsStartingWithTilde()
    ' Implement your logic to delete rows starting with tilde (~) if needed
    ' This subroutine can be customized based on your requirements
End Sub

Sub RemoveTime()
    ' Implement your logic to remove time from the date column if needed
    ' This subroutine can be customized based on your requirements
End Sub

 

[howard]

I managed to amend my code and it works perfectly now

 Sub Open_ImportTemplates()
    Dim FolderPath As String
    Dim searchText As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim SubFolder As Object
   
    FolderPath = "\\MTR\Sales" ' Specify the main folder path
    searchText = "*Import Template*" ' Specify the text to search with wildcards
   
    ' Set the worksheet to import the file names and modified dates
    Set ws = ThisWorkbook.Sheets("Import Templates")
   
    ' Clear existing data in column A starting from row 2
    ws.Range("A2:A" & ws.Rows.Count).ClearContents
   
    ' Start searching in first-level subfolders
    lastRow = 2 ' Start copying file names from row 2
    For Each SubFolder In CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath).Subfolders
        RecursiveFileSearch SubFolder.Path, searchText, ws, lastRow
    Next SubFolder
   
    DeleteRowsStartingWithTilde
End Sub

Sub RecursiveFileSearch(ByVal FolderPath As String, ByVal searchText As String, ByRef ws As Worksheet, ByRef lastRow As Long)
    Dim file As Object
    Dim files As Object
    Dim lastModified As Date
   
    ' Create file system objects
    Set files = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath).Files
   
    ' Check files in the current folder
    For Each file In files
        If UCase(file.Name) Like UCase(searchText) And Left(file.Name, 1) <> "~" Then
            lastModified = file.DateLastModified
            ' Check if the file was modified within the last 60 days
            If DateDiff("d", lastModified, Date) <= 60 Then
                ' Extract file name and copy to the Import Templates sheet
                ws.Cells(lastRow, "A").Value = file.Name
                lastRow = lastRow + 1
                Application.DisplayAlerts = False ' Suppress display alerts
                Application.ScreenUpdating = False ' Turn off screen updating
                Application.Workbooks.Open file.Path, UpdateLinks:=True ' Open the file without displaying messages
                Application.DisplayAlerts = True ' Enable display alerts
                Application.ScreenUpdating = True ' Turn on screen updating
            End If
        End If
    Next file
End Sub

Sub DeleteRowsStartingWithTilde()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
   
    ' Set the worksheet to the desired sheet
    Set ws = ThisWorkbook.Sheets("Import Templates") ' Replace "Import Templates" with the actual sheet name
   
    ' Find the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    ' Loop through each cell in column A from bottom to top
    For i = lastRow To 1 Step -1
        ' Check if the cell starts with a tilde (~)
        If Left(ws.Cells(i, "A").Value, 1) = "~" Then
            ' Delete the entire row if the condition is met
            ws.Rows(i).Delete Shift:=xlUp
        End If
    Next i
   
    ' Display a message box with the count
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRow > 1 Then
        MsgBox "Found " & lastRow - 1 & " file(s) with the text 'Import Template'." & vbCrLf & _
               "File names have been imported to the 'Import Templates' sheet."
    Else
        MsgBox "No files found with the text 'Import Template'."
    End If
End Sub