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

Keevin

New Member
Joined
Dec 6, 2020
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,384
VBA Code:
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

New Member
Joined
Dec 6, 2020
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
VBA Code:
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

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,384
VBA Code:
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
 
Solution

Keevin

New Member
Joined
Dec 6, 2020
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
VBA Code:
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!
 

Watch MrExcel Video

Forum statistics

Threads
1,123,231
Messages
5,600,427
Members
414,384
Latest member
joehalks

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top