View Single Post
 
Old 12-30-2022, 01:39 PM
macropod's Avatar
macropod macropod is offline Windows 10 Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote