Try:
Code:
Sub InvoiceArchiver()
Application.ScreenUpdating = False
Dim FSO As Object, r As Long, i As Long, StrSrc, StrTgt, StrFlNm As String, StrTmp As String
Set FSO = CreateObject("Scripting.FileSystemObject")
With ActiveSheet
For r = 2 To .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
StrFlNm = .Range("C" & r): StrSrc = ThisWorkbook.Path & "\": StrTgt = .Range("D" & r): StrTmp = ""
'Confirm the source file exists
If Dir(StrSrc & StrFlNm, vbNormal) <> "" Then
'Confirm the destination folder exists, & create it if needed
If Dir(StrTgt, vbDirectory) = "" Then
For i = 0 To UBound(Split(StrTgt, "\")) - 1
StrTmp = StrTmp & Split(StrTgt, "\")(i) & "\"
If Dir(StrTmp, vbDirectory) = "" Then MkDir StrTmp
Next
End If
'Delete any existing copy of the file in the destination folder
If Dir(StrTgt & StrFlNm, vbNormal) <> "" Then Kill StrTgt & StrFlNm
'Move the file
FSO.MoveFile StrSrc & StrFlNm, StrTgt & StrFlNm
End If
Next
End With
Application.ScreenUpdating = True
End Sub