1
\$\begingroup\$

I often have multiple versions of the same reports that accumulate in some directory. I'd like to automate the process of moving the "old" versions of each report into an archive.

Sometimes these report titles are formatted so that the date is at the end of the file name (before the extension), but the date format can vary from report to report. For example:

  • Tax Report 5.1.17.xlsx
  • Tax Report 12.1.17.xlsx
  • Compliance Report 5-1-2017.xlsx
  • Compliance Report 6-1-2017.xlsx
  • Insurance Report (May 2017).pdf
  • Insurance Report (June 2017).pdf

Each report should be handled separately (ie I'd like to keep the "newest" version of each report that I specify) based on a partial string identifier. The dates will be extracted using InStrRev and start/end indicators (by default, " " is the start indicator and "." is the end indicator).

So if all of the files above were in the same directory and I ran the code below, the files with "May" dates would be archived, and the others would remain.

Dim sourceDir As String
Dim backupDir As String
sourceDir = "C:\Users\johndoe\Reports\"
backupDir = "C:\Users\johndoe\Reports\Archive\"
Call archiveFiles(sourceDir, backupDir, Array("Tax*", "Comp*"), True)
Call archiveFiles(sourceDir, backupDir, "Ins*", True, "(", ")")

Other times the report titles might not include dates, or the dates may be in a non-standard format. So I've included the option to determine the "newest" report based on date created or date modified (If you try to use the "date string" version and the procedure can't find any file names with valid dates, it won't move any of the files).

I'm open to any feedback that might improve speed/stability/flexibility/readability/etc. I've tried to account for the obvious potential errors (trying to move an open file, trying to move a file to a directory containing an identically named file, etc.) but I may have missed some.

Option Explicit
Sub archiveFiles(sourcePath As String, backupPath As String, ByVal toMove As Variant, Optional leaveNewest As Boolean = False, Optional ByVal dateType As Variant = 1, Optional startIndicator As String = " ", Optional endIndicator As String = ".")
'Moves files meeting name criteria (toMove) from one path (sourcePath) to another (backupPath)
'If a file already exists in the backup folder, version number is added to file name
'Optionally leaves the "newest" file, which can be determined based on (by dateType)
' - Date within file name ("String" or 1)
' - Date file created ("Created" or 2)
' - Date file last modified ("Modified" or 3)

    If Not IsArray(toMove) Then
        Dim tempStr As String
        tempStr = toMove
        ReDim toMove(1 To 1) As String
        toMove(1) = tempStr
    End If

    Dim i As Long
    For i = LBound(toMove) To UBound(toMove)
        If leaveNewest Then
            Dim keepName As String
            keepName = getNewestFile(sourcePath, CStr(toMove(i)), dateType, startIndicator, endIndicator)
        End If
        Dim FSO As Object
        Set FSO = CreateObject("Scripting.Filesystemobject")
        Dim f As Object
        For Each f In FSO.GetFolder(sourcePath).Files
            If f.Name Like CStr(toMove(i)) Then
                Dim goAhead As Boolean
                If Not leaveNewest Then
                    goAhead = True
                ElseIf f.Name = keepName Then
                    goAhead = False
                ElseIf keepName = "" Then
                    goAhead = False
                Else
                    goAhead = True
                End If
                If goAhead Then
                    If Not isFileOpen(f) Then
                        Dim j As Long
                        Dim fMoved As Boolean
                        j = 1
                        fMoved = False
                        Do Until fMoved
                            If Dir(backupPath & f.Name) <> "" Then
                                Dim fileExt As String
                                fileExt = Right(f.Name, Len(f.Name) - InStrRev(f.Name, ".") + 1)
                                If j = 1 Then
                                    f.Name = Left(f.Name, InStrRev(f.Name, ".") - 1) & " v1" & fileExt
                                Else
                                    f.Name = Left(f.Name, InStrRev(f.Name, ".") - Len(CStr(j)) - 1) & j & fileExt
                                End If
                                j = j + 1
                            Else
                                f.Move backupPath
                                fMoved = True
                            End If
                        Loop
                    End If
                End If
            End If
        Next
    Next
End Sub
Function getNewestFile(strDir As String, Optional strFileName As String = "*", Optional ByVal dateType As Variant = 1, Optional startIndicator As String = " ", Optional endIndicator As String = ".") As String
'Returns the name of the "newest" file in a directory (strDir) with a given filename (strFileName)
'Determines newest file using dateType, which can be:
' - "String" or 1 (date within file name),
' - "Created" or 2 (date file created), or
' - "Modified" or 3 (date file last modified)

    If Not IsNumeric(dateType) Then
        Select Case dateType
        Case "Modified"
            dateType = 3
        Case "Created"
            dateType = 2
        Case "String"
            dateType = 1
        Case Else
            MsgBox "Invalid date type"
            getNewestFile = ""
        End Select
    ElseIf dateType < 1 Or dateType > 3 Then
        MsgBox "Invalid date type"
        getNewestFile = ""
    End If

    Dim tempName As String
    Dim tempDate As Date
    tempName = ""
    tempDate = DateSerial(1900, 1, 1)

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.Filesystemobject")
    Dim f As Object
    For Each f In FSO.GetFolder(strDir).Files
        If f.Name Like strFileName Then
            If dateType = 3 Then
                If f.DateLastModified > tempDate Then
                    tempDate = f.DateLastModified
                    tempName = f.Name
                End If
            ElseIf dateType = 2 Then
                If f.DateCreated > tempDate Then
                    tempDate = f.DateCreated
                    tempName = f.Name
                End If
            Else
                Dim tempStart As String
                Dim tempEnd As String
                Dim tempStr As String
                tempStart = InStrRev(f.Name, startIndicator) + 1
                tempEnd = InStrRev(f.Name, endIndicator) - 1
                tempStr = Replace(Mid(f.Name, tempStart, tempEnd - tempStart + 1), ".", "/")
                If tempStart > 0 And tempStart < tempEnd Then
                    If IsDate(tempStr) Then
                        If CDate(tempStr) > tempDate Then
                            tempDate = CDate(tempStr)
                            tempName = f.Name
                        End If
                    End If
                End If
            End If
        End If
    Next

    getNewestFileName = tempName

End Function
Function isFileOpen(ByVal f As Variant) As Boolean
'Determines whether a file (f) is open and returns true or false
'Parameter "f" can be passed as a File object or as a complete file path string

    Dim errNum As Long
    Dim fileNum As Long
    fileNum = FreeFile()

    On Error Resume Next
    If IsObject(f) Then
        Open f.Path For Input Lock Read As #fileNum
    Else
        Open f For Input Lock Read As #fileNum
    End If
    Close fileNum
    errNum = Err
    On Error GoTo 0

    Select Case errNum
        Case 0
            isFileOpen = False
        Case 70
            isFileOpen = True
        Case Else
            Error errNum
    End Select

End Function
\$\endgroup\$

1 Answer 1

1
\$\begingroup\$

You have quite the case of arrow code there. Personally, I'm not sure VBA is the way to go on this, but that's what you've done and I will review it.

Here's your skeleton for the arrow code (in archiveFiles).

For i = LBound(toMove) To UBound(toMove)
For Each f In FSO.GetFolder(sourcePath).Files
    If f.Name Like CStr(toMove(i)) Then

        If Not leaveNewest Then
            goAhead = True
        ElseIf f.Name = keepName Then
            goAhead = False
        ElseIf keepName = "" Then
            goAhead = False
        Else
            goAhead = True
        End If
            If goAhead Then
                If Not isFileOpen(f) Then
                    Do Until fMoved
                        If Dir(backupPath & f.Name) <> "" Then
                        If j = 1 Then
                            f.Name = Left(f.Name, InStrRev(f.Name, ".") - 1) & " v1" & fileExt
                        Else
                            f.Name = Left(f.Name, InStrRev(f.Name, ".") - Len(CStr(j)) - 1) & j & fileExt
                        End If
                        j = j + 1

It looks like several levels could be combined here

If leaveNewest Or f.Name = keepName Or keepName = vbNullString Then
   goAhead = False
Else
   goAhead = True
End If

But, that False is basically a GoTo Next. Also, we know you won't error on isFileOpen(f) because you've already determined f can be tested. So now we can get this -

For i = LBound(toMove) To UBound(toMove)
    For Each f In FSO.GetFolder(sourcePath).Files
        If f.Name Like CStr(toMove(i)) Then
            If leaveNewest Or f.Name = keepName Or keepName = vbNullString Or isFileOpen(f) Then GoTo Skip
            j = 1
            fMoved = False
            Do Until fMoved
                If Dir(backupPath & f.Name) <> vbNullString Then
                    If j = 1 Then
                        f.Name = Left(f.Name, InStrRev(f.Name, ".") - 1) & " v1" & fileExt
                    Else
                        f.Name = Left(f.Name, InStrRev(f.Name, ".") - Len(CStr(j)) - 1) & j & fileExt
                    End If
                    j = j + 1
                End If
            Loop
        End If
Skip:
    Next
Next

Still pretty arrow-like. What should we do? Refactor? Sure

For i = LBound(toMove) To UBound(toMove)
    For Each f In FSO.GetFolder(sourcePath).Files
        If f.Name Like CStr(toMove(i)) Then
            If leaveNewest Or f.Name = keepName Or keepName = vbNullString Or isFileOpen(f) Then GoTo Skip
            DoWork f.Name, fileExt
        End If
Skip:
    Next
Next

Private Sub DoWork(ByVal fileName As String, ByVal fileExt As String, ByVal backupPath as String)
Dim fMoved As Boolean
fMoved = False
Dim j As long
j = 1
Do Until fMoved
    If Dir(backupPath & fileName) <> vbNullString Then
        If j = 1 Then
            fileName = Left(fileName, InStrRev(fileName, ".") - 1) & " v1" & fileExt
        Else
            fileName = Left(fileName, InStrRev(fileName, ".") - Len(CStr(j)) - 1) & j & fileExt
        End If
        j = j + 1
    Else
    fileName.Move backupPath 
    fMoved = True
    End If
Loop
End Sub

Since we got rid of that pesky middle, I don't think we need that skip anymore -

For i = LBound(toMove) To UBound(toMove)
    For Each f In FSO.GetFolder(sourcePath).Files
        If f.Name Like CStr(toMove(i)) Then
            If Not leaveNewest And Not f.Name = keepName _
            And Not keepName = vbNullString And Not isFileOpen(f) Then
            DoWork f.Name, fileExt, backupPath
        End If
    Next
Next
\$\endgroup\$
4
  • \$\begingroup\$ I think you've left out a chunk of the "DoWork" section, as written the "firstTry" and "fMoved" variables are never referenced and it'll run in an endless loop. I also have no idea what you mean by "making constants" for those parameters; they're used to identify how the date in a file name is delimited, which can vary (ie is the file name "test 3.22.18.xlsx" or "test (3-22-18).xlsx") and is thus passed to the function when it's used. \$\endgroup\$ Mar 22, 2018 at 22:54
  • \$\begingroup\$ Yeah, you're right on that, whoops. I invented that first Try - should have been j. Re: Constants - I mean like Const Delimiter as String = "." and then Optional endIndicator ass String = Delimiter" and then use the endIndicator` variable when naming your files. \$\endgroup\$ Mar 22, 2018 at 23:06
  • \$\begingroup\$ The portion where the value of "goAhead" is determined could definitely be rewritten using some ANDs. But due to VBA's lack of short-circuit evaluation, the call to "isFileOpen" should almost definitely be separate. There's no point in making a relatively expensive function call to check if a file is open before we've decided whether it needs to be moved, that just adds to the runtime. \$\endgroup\$ Mar 22, 2018 at 23:06
  • \$\begingroup\$ Again, I think you're misunderstanding what the start/end indicator parameters are used for. They're not used to name files, they're used to find the dates embedded in the existing files' names, then protect the "newest" file from being moved. The hard-coded "." references in the "fileName = ..." section are entirely separate; they're used to separate the file's name from its extension when adding a version number. I don't really see the value in adding an additional line of code to declare a constant for a 1-character literal that's used twice, it makes the code more confusing imo. \$\endgroup\$ Mar 22, 2018 at 23:17

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.