Moving files Macro

[ninjabik2001]

Hi, I am still fairly new at coding. I have this macro (not mine, I didn't write it) that works perfectly but I don't want it to copy. I want it to cut and paste the files instead of copying. That way, they no longer exist in the folder from where I moved them from. I have tried to figure it out, but can' find the answer. Thanks ahead of time. The current working code is below.

Public Sub MoveFiles()
' Move any FolderA files (columnA) to dirs in ColumnB
'

Const colA = 1
Const colB = 2
Const colC = 3
Const FolderA = "S:\dept\THN\Dashboard - PCP Quality\2019" ' NOTE trailing backslash
Const srcSheet = "Source"

Dim xlS As Excel.Worksheet
Dim xlW As Excel.Workbook
Dim RN As Long ' row number
Dim fName As String
Dim fPath As String

' get ready

Set xlW = ActiveWorkbook
Set xlS = xlW.Sheets(srcSheet)

RN = 2
fName = Trim(xlS.Cells(RN, colA).Text)

' We'll run thru ColA until we hit a blank

On Error Resume Next ' expect problems if no target Dir

While fName <> ""

' if it hasn't aready been moved

If Trim(xlS.Cells(RN, colC).Text) = "" Then

' got one.
' Get the path. Ensure trailing backslash

fPath = Trim(xlS.Cells(RN, colB).Text)

If Right(fPath, 1) <> "" Then fPath = fPath & ""

' if the target already exists, nuke it.

If Dir(fPath & fName) <> "" Then Kill fPath & fName

' move it

FileCopy FolderA & fName, fPath & fName
DoEvents

' report it

If Err.Number <> 0 Then

xlS.Cells(RN, colC).Value = "Failed: Check target Dir"

Err.Clear

Else

xlS.Cells(RN, colC).Value = Now()

End If
End If

' ready for next one

RN = RN + 1
fName = Trim(xlS.Cells(RN, colA).Text)

Wend

MsgBox "Done it!!"

End Sub

 

[rlv01]

If as you say, the code you posted "works perfectly", then all you should need to do is add a VBA "kill" statement after FileCopy to delete the source file after it is copied.

            ' move it
            FileCopy FolderA & fName, fPath & fName
[COLOR="#0000FF"]            Kill FolderA & fName[/COLOR]
            DoEvents