VB search folder for older version of a file and move it to archive

[Davefromleeds]

Hello all,

I am working a reporting automation for multiple projects. Have a macro set up to save a copy of the file, renaming it as the project name (from a cell) and Todays date in the format " test dd-mm-yyyy".

I am running this as a way to the consolidate all the data into on file by looking into the existing folder. We want to to keep the audibility of past versions of the the plans so we dont want to just rename it or delete the old versions.

What i am looking for help with is to create a loop that looks through all the files in a folder containing the Project name, then move all but the latest into an archive folder. Been hitting my head against a wall with this for a month on and off and realised i cant figure it out on my own.

thanks for your help in advance.

 

[AlphaFrog]

A couple of questions\comments if you don't mind...

1.) Is this Archiving macro going to be run from the latest version of the file?

1B.) You then want to archive all other versions with the same Project name but older dates?

2.) Why doesn't your Save-a-copy macro save directly to the Archive folder?

3.) If you look in the project folder with a File Manager program, and sort by Last Modified, you could easily group-select all the older files and drag them to the archive folder.

4.) If you saved the copies with this naming format "ProjectName yyyy-mm-dd", they would sort both alphabetically and chronologically in the file list.

 

[Candyman8019]

You can try something like this. It will essentially rename files with a different path as long as the filename contains the characters you specify...in this case your project name.

Private Sub renamefiles()

Dim FileName As Variant
Dim sourcepath As String
Dim destpath As String
Dim fs As Object

sourcepath = "c:\users\user\documents\"          'Update to your Source Path
destpath = "c:\users\user\documents\archive\"    'Update to your Archive path
  
Set fs = CreateObject("scripting.filesystemobject")
FileName = Dir$(sourcepath & "*", vbNormal)
 
    Do While FileName <> ""

        If InStrRev(FileName, "Test1") > 0 Then       'Change Test1 to your project name.
            Name sourcepath & FileName As destpath & FileName
        End If
      FileName = Dir$()
    Loop

Set fs = Nothing
Set FileName = Nothing
  
'Insert your macro code to save a copy of the file, renaming it as the project name (from a cell) and Todays date in the format " test dd-mm-yyyy".

End Sub

 

[AlphaFrog]

Set fs = CreateObject("scripting.filesystemobject")

@ Candyman8019
The code doesn't exclude the most recent file.
The code creates a Scripting.Filesystemobject, but doesn't utilize it.

 

[Candyman8019]

@ Candyman8019
The code doesn't exclude the most recent file.
The code creates a Scripting.Filesystemobject, but doesn't utilize it.

ah Yes, good catch. That line can be removed. I pared down another script that I have and missed removing that line. As for the most recent file, as per the comment in the code, I suggested adding script to save the file at the end with the existing nomenclature so the user is left with only the current file in the folder.

 

[Davefromleeds]

A couple of questions\comments if you don't mind...

1.) Is this Archiving macro going to be run from the latest version of the file?

1B.) You then want to archive all other versions with the same Project name but older dates?

2.) Why doesn't your Save-a-copy macro save directly to the Archive folder?

3.) If you look in the project folder with a File Manager program, and sort by Last Modified, you could easily group-select all the older files and drag them to the archive folder.

4.) If you saved the copies with this naming format "ProjectName yyyy-mm-dd", they would sort both alphabetically and chronologically in the file list.

Thanks for asking for clarification

1. We have multiple people having different project plans. they have them in their project folders. the MACRO is to save a copy of their updates to the Common folder with a date marker. so they should not be working on the file in that folder, tough you know with people they will do whatever they want. They might be working the latest version in that folder.

1b. I want to archive all but the latest date. now when it is automated is should only be one other file as the script will move the older ones as soon as possible.

2. It does not save to the archive folder automatically as i use the folder on another spreadsheet to consolidate selected data, milestones, from multiple project plans into one so having only the latest up to date info allows for that. if not you would have multiple versions in the consolidation.

3. I am manually archiving but i want to make it automated so that it removes this task that can be forgotten.

4. this could help as you could use then sort by largest Number in some way


below is my code as you can see i have been working some extra Dims in to try and make it work.

Sub File_Name_As_Cell_Value()
Dim File_Name As String
Dim Destination As String
Dim Destination2 As String
Dim File_Contain As String
Dim Project As String
Application.DisplayAlerts = False
Destination = "\\"*"\Live Project Plans\"
File_Name = Range("C7").Value & Format(Now(), " DD-MM-YYYY")
Destination2 = "\\"*"\Live Project Plans\Archive\"
File_Contain = "\\"*"\Live Project Plans\" & Range("C7").Value & "*" & ".xlsm"
Project = Range("C7").Value
If FileSystem.Dir("\\"*"\Live Project Plans\" & File_Name & ".xlsm") = vbNullString Then
   ActiveWorkbook.Save
   ActiveWorkbook.SaveCopyAs Destination & File_Name & ".xlsm"
Else
    ActiveWorkbook.Save
End If
Call Shell("explorer.exe" & " " & "\\"*"\Live Project Plans\", vbNormalFocus)
Application.DisplayAlerts = True
End Sub

@ Candyman8019

Thanks for this, I was wondering about this but this would not work if you have the latest file open.

 

[AlphaFrog]

Sub File_Name_As_Cell_Value()
    Dim File_Name As String
    Dim Destination As String
    Dim Destination2 As String
    Dim File_Contain As String
    Dim Project   As String
    Dim strFile As String
  
    Application.DisplayAlerts = False
  
    Destination = "\\" * "\Live Project Plans\"
    File_Name = Range("C7").Value & Format(Now(), " DD-MM-YYYY")
    Destination2 = "\\" * "\Live Project Plans\Archive\"
    File_Contain = "\\" * "\Live Project Plans\" & Range("C7").Value & "*" & ".xlsm"
    Project = Range("C7").Value
  
    If FileSystem.Dir("\\" * "\Live Project Plans\" & File_Name & ".xlsm") = vbNullString Then
        ActiveWorkbook.Save
        ActiveWorkbook.SaveCopyAs Destination & File_Name & ".xlsm"
        'Archive old files
        strFile = Dir(Destination & Project & "*")
        Do While strFile <> ""
            If strFile <> File_Name & ".xlsm" Then Name Destination & strFile As Destination2 & strFile
            strFile = Dir() 'Next file
        Loop
    Else
        ActiveWorkbook.Save
    End If
  
    Call Shell("explorer.exe" & " " & "\\" * "\Live Project Plans\", vbNormalFocus)
  
    Application.DisplayAlerts = True
End Sub

 

[Davefromleeds]

Sub File_Name_As_Cell_Value()
    Dim File_Name As String
    Dim Destination As String
    Dim Destination2 As String
    Dim File_Contain As String
    Dim Project   As String
    Dim strFile As String
 
    Application.DisplayAlerts = False
 
    Destination = "\\" * "\Live Project Plans\"
    File_Name = Range("C7").Value & Format(Now(), " DD-MM-YYYY")
    Destination2 = "\\" * "\Live Project Plans\Archive\"
    File_Contain = "\\" * "\Live Project Plans\" & Range("C7").Value & "*" & ".xlsm"
    Project = Range("C7").Value
 
    If FileSystem.Dir("\\" * "\Live Project Plans\" & File_Name & ".xlsm") = vbNullString Then
        ActiveWorkbook.Save
        ActiveWorkbook.SaveCopyAs Destination & File_Name & ".xlsm"
        'Archive old files
        strFile = Dir(Destination & Project & "*")
        Do While strFile <> ""
            If strFile <> File_Name & ".xlsm" Then Name Destination & strFile As Destination2 & strFile
            strFile = Dir() 'Next file
        Loop
    Else
        ActiveWorkbook.Save
    End If
 
    Call Shell("explorer.exe" & " " & "\\" * "\Live Project Plans\", vbNormalFocus)
 
    Application.DisplayAlerts = True
End Sub

Thanks so much. i was so close but just did slightly different. thanks