Hi,
I have finally managed to string together (with a lot of help of-course) VBA that essentially archives the latest excel file in each folder that was created less than the date ran ie:-todays date, but my VBA is terrible so when I step through the code it its all over the place and very slow when there are lots of folders with hundreds of files, I was hoping that a guru could suggest a more efficient way to do the exact same or just clean up so it would run faster, this would suit me and any others that need a similar system for backups. many thanks in advance for any suggestions
Option Explicit


Sub Findfolders()

Dim FileSystem As Object
Dim Hostfolder1 As String
Dim fso As Scripting.FileSystemObject

Hostfolder1 = "P:\Management\Industries Control\Archives\Temp\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")

    DoFolder1 FileSystem.GetFolder(Hostfolder1)

End Sub

Sub DoFolder1(Folder)

    Dim subfolder
    Dim FolderName1 As String
    Dim LCF As Date
    Dim todays_date As Date
    Dim fld As Scripting.Folder
    Dim FileSystem As Object

        todays_date = Format(Date, "DD-MMm-YY")
        

    For Each subfolder In Folder.SubFolders
   

    'MsgBox SubFolder

        DoFolder1 subfolder

        LCF = VBA.DateValue(subfolder.DateCreated)

         If LCF < todays_date Then

            FolderName1 = subfolder

            Call IndCtl_FindNewestFile(FolderName1)

         ElseIf LCF >= todays_date Then

              ' MsgBox "Greater than todays date" & vbNewLine & " Do nothing and exit sub"

           ' Exit Sub

         End If

    Next

        'Set fld = Nothing

        'Set fso = Nothing
End Sub

Sub IndCtl_FindNewestFile(FolderName1 As String)

    Dim MyPath As String
    Dim subfolder As String
    'Dim FolderName1 As String
    Dim MyFile As String
    Dim LatestFile As String
    Dim LatestDate As Date
    Dim LCF As Date
    Dim DestinationFolder As String
    Dim dt_today As Variant

    dt_today = Format(Date, "DD-MMm-YY")

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    
       MyPath = FolderName1
   

        DestinationFolder = "P:\Management\Industries Control\Archived\"
                            'may need to append todays date on end
                            'so each folder (date named) contain one LCD archived file

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

' Check and add a backslash \ if not already got one

If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

        MyFile = Dir(MyPath & "*.xlsm", vbNormal)

    If Len(MyFile) = 0 Then

       ' MsgBox "No files were found…", vbExclamation

        Exit Sub

    End If

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

            Do While Len(MyFile) > 0   'loop through each file and get Last created Date

                LCF = FileDateTime(MyPath & MyFile)

                        If LCF > LatestDate Then 'DT_Today

                            LatestFile = MyFile
                            LatestDate = LCF 'latest created (and not the modified date)
                        End If

 '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

                MyFile = Dir

            Loop


    'move the LCF file to the archived folder
       
    dt_today = Format(Now, "DD-MMm-YY")

    DestinationFolder = DestinationFolder & dt_today & "\"

   ' MsgBox DestinationFolder

         If Dir(DestinationFolder, vbDirectory) = "" Then
         

          MkDir DestinationFolder

         
      End If
      
    FileCopy MyPath & LatestFile, DestinationFolder & LatestFile

    'If Len(MyFile) > 0 Then

     Kill MyPath & "*.*"

    RmDir MyPath
    
End Sub