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