VBA move listed files to archive, rename with version number if exists

[Keevin]

Hi I am seeking help to fix the below VBA. This should move the listed files in column M to Archive folder, and rename by adding version number for the files that exist in Archive folder. The Archive folder is located in the same folder where the macro-enabled excel file and the listed files are located. The list of filenames are in M5:M(last non blank row) and the names include file extensions (i.e PETROVIE 01012021.pdf).

The below code only moves the files that do not exist in Archive folder, but cannot rename the file in current folder and then move to Archive folder.

Can somebody please help me fix this code?

==VBA Code==

Sub MoveFiles()
On Error GoTo Errproc

Dim sFromPath As String
Dim sDestPath As String
Dim k As Integer
'Const sFileType As String = ".pdf"
sFromPath = ActiveWorkbook.Path & "\"
sDestPath = sFromPath & "Archive\"
'validate destination folder
If Len(Dir(sDestPath)) = 0 Then
MsgBox "Destination path does not exist..."
Exit Sub
End If

Dim iRow As Integer
iRow = Range("M" & Rows.Count).End(xlUp).Row

Dim rr As Range, r As Range
Dim FileName As String
Set rr = Range("M5:M" & iRow)

Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

For Each r In rr
With objFSO
If Not .FileExists(sDestPath & r.Value) Then
objFSO.MoveFile Source:=sFromPath & r.Value, Destination:=sDestPath
Else
FileName = r.Value
Do Until .FileExists(sDestPath & FileName) = 0
k = k + 1
FileName = Replace(FileName, ".pdf", "-" & k & ".pdf")

Loop

objFSO.MoveFile Source:=sFromPath & FileName, Destination:=sDestPath

End If
End With
Next r

Leave:
Set objFSO = Nothing
On Error GoTo 0
Exit Sub

Errproc:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub

 

[AlphaFrog]

Sub MoveFiles()
   
    Dim sFromPath As String
    Dim sDestPath As String
    Dim r         As Range
    Dim FileName  As String
    Dim counter   As Long
   
    'Const sFileType As String = ".pdf"
    sFromPath = ActiveWorkbook.Path & "\"
    sDestPath = sFromPath & "Archive\"
    'validate destination folder
    If Len(Dir(sDestPath, vbDirectory)) = 0 Then MkDir sDestPath
   
    For Each r In Range("M5", Range("M" & Rows.Count).End(xlUp))
        If LCase(r.Value) Like "*.pdf" Then
       
            FileName = Dir(sFromPath & Replace(r.Value, ".pdf", "*.pdf"))
           
            Do While FileName <> ""
                Name sFromPath & FileName As sDestPath & FileName
                FileName = Dir
                DoEvents
                counter = counter + 1
            Loop
        End If
    Next r
       
    MsgBox counter & " files archived.", vbInformation, "Archive Files Complete"
   
End Sub

 

[Keevin]

Sub MoveFiles()
  
    Dim sFromPath As String
    Dim sDestPath As String
    Dim r         As Range
    Dim FileName  As String
    Dim counter   As Long
  
    'Const sFileType As String = ".pdf"
    sFromPath = ActiveWorkbook.Path & "\"
    sDestPath = sFromPath & "Archive\"
    'validate destination folder
    If Len(Dir(sDestPath, vbDirectory)) = 0 Then MkDir sDestPath
  
    For Each r In Range("M5", Range("M" & Rows.Count).End(xlUp))
        If LCase(r.Value) Like "*.pdf" Then
      
            FileName = Dir(sFromPath & Replace(r.Value, ".pdf", "*.pdf"))
          
            Do While FileName <> ""
                Name sFromPath & FileName As sDestPath & FileName
                FileName = Dir
                DoEvents
                counter = counter + 1
            Loop
        End If
    Next r
      
    MsgBox counter & " files archived.", vbInformation, "Archive Files Complete"
  
End Sub

Thank you AlphaFrog for your help. This code copies the file from current folder to archive folder if same file does not exist in archive folder, but stops if filename already exists in archive folder. I was looking to get the VBA to rename the files that exist in archive folder by addition of count number and then move to archive folder.
Therefore, the VBA is supposed to do:
1. Check existence of each filename appearing in list M5:M LastRow in archive folder (they all definitely exist in current folder, but some filename may exist already in archive folder)
2. If the file does not exist in archive folder, then move the file from current folder to archive folder - no change of filename required
3. Else (when the same file name exist in archive folder), rename the filename by adding 1/2/3 etc. and then move to archive folder.
4. Loop through 1 to 3 until file list in M5: M LastRow exhausts

 

[AlphaFrog]

Sub MoveFiles()
   
    Dim sFromPath As String
    Dim sDestPath As String
    Dim r         As Range
    Dim FileName  As String
    Dim NewFileName As String
    Dim counter   As Long
    Dim k         As Long
   
    'Const sFileType As String = ".pdf"
    sFromPath = ActiveWorkbook.Path & "\"
    sDestPath = sFromPath & "Archive\"
    'validate destination folder
    If Len(Dir(sDestPath, vbDirectory)) = 0 Then MkDir sDestPath
   
    For Each r In Range("M5", Range("M" & Rows.Count).End(xlUp))
        FileName = r.Value
        If LCase(FileName) Like "*.pdf" Then
            If Len(Dir(sFromPath & FileName)) Then
            
                If Len(Dir(sDestPath & FileName)) = 0 Then
                    Name sFromPath & FileName As sDestPath & FileName
                Else
                    k = 0
                    Do
                        k = k + 1
                        NewFileName = Replace(FileName, ".pdf", "-" & k & ".pdf")
                        DoEvents
                    Loop Until Dir(sDestPath & NewFileName) = ""
                    Name sFromPath & FileName As sDestPath & NewFileName
                End If
                
                counter = counter + 1
            End If
        End If
    Next r
       
    MsgBox counter & " files archived.", vbInformation, "Archive Files Complete"
   
End Sub

 

[Keevin]

Sub MoveFiles()
  
    Dim sFromPath As String
    Dim sDestPath As String
    Dim r         As Range
    Dim FileName  As String
    Dim NewFileName As String
    Dim counter   As Long
    Dim k         As Long
  
    'Const sFileType As String = ".pdf"
    sFromPath = ActiveWorkbook.Path & "\"
    sDestPath = sFromPath & "Archive\"
    'validate destination folder
    If Len(Dir(sDestPath, vbDirectory)) = 0 Then MkDir sDestPath
  
    For Each r In Range("M5", Range("M" & Rows.Count).End(xlUp))
        FileName = r.Value
        If LCase(FileName) Like "*.pdf" Then
            If Len(Dir(sFromPath & FileName)) Then
           
                If Len(Dir(sDestPath & FileName)) = 0 Then
                    Name sFromPath & FileName As sDestPath & FileName
                Else
                    k = 0
                    Do
                        k = k + 1
                        NewFileName = Replace(FileName, ".pdf", "-" & k & ".pdf")
                        DoEvents
                    Loop Until Dir(sDestPath & NewFileName) = ""
                    Name sFromPath & FileName As sDestPath & NewFileName
                End If
               
                counter = counter + 1
            End If
        End If
    Next r
      
    MsgBox counter & " files archived.", vbInformation, "Archive Files Complete"
  
End Sub

OMG! This is exactly what I needed. Thank you soooooooooooooooo much, you made my day! You are just awesome!