Copy/move files based on excel table

Hi, I have the following data in an excel table:

284-406-20220721-08_01.pdf	2118
298-297-20220720-09_02.pdf	2134
320-319-20220728-08_07.pdf	1645
352-351-20220805-12_57.pdf	1427

I have the following code which allows me to create a button to select the source folder, destination folder, and run the macro. I really like how this runs and highlights any files not found. But it only scans the files and copies them into the destination folder. But I'm looking to modify it to fit what I need.

'-----------------------------------SELECTING SOURCE FOLDER--------------------------------------------
Sub SelectFolder1()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With

If sFolder <> "" Then ' if a file was chosen
Range("B4").Value = sFolder
End If
End Sub

'-----------------------------------SELECTING DESTINATION FOLDER--------------------------------------------
Sub SelectFolder2()
Dim sFolder2 As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder2 = .SelectedItems(1)
End If
End With

If sFolder2 <> "" Then ' if a file was chosen
Range("B8").Value = sFolder2
End If
End Sub

'-----------------------------------COPY FILES--------------------------------------------
Sub CopyFilesX()
Dim sSrcFolder As String, sTgtFolder As String, sFilename As String
Dim c As Range, rPatterns As Range
Dim bBad As Boolean

sSrcFolder = ActiveSheet.Range("B4").Value
sTgtFolder = ActiveSheet.Range("B8").Value

Dim lastRow As Long
lastRow = Range("A1").End(xlDown).Row

Set rPatterns = ActiveSheet.Range("A2:A" & lastRow).SpecialCells(xlConstants)
For Each c In rPatterns
sFilename = Dir(sSrcFolder & "\" & "*" & c.Text & "*")
If sFilename = "" Then
c.Interior.ColorIndex = 3
bBad = True
Else
While sFilename <> ""
FileCopy sSrcFolder & "\" & sFilename, sTgtFolder & "\" & sFilename
sFilename = Dir()
c.Interior.ColorIndex = 4
Wend
End If
Next c
If bBad Then MsgBox "Some files were not found. " & _
"These were highlighted for your reference."
End Sub

First, I need it to run from the table on sheet 2 instead of the active sheet. I would like to have directions on the first sheet with buttons to select the source, destination, and to run it.

Second, I need a folder created in the destination folder that matches with column B and then have the file copied to that folder.

For example:

C:\source\284-406-20220721-08_01.pdf would be copied over to C:\destination\2118\284-406-20220721-08_01.pdf

Is this something that someone can help me modify this code to work like this?

Thank you!

I've found an easier way using this code:

Sub Move()
Dim a$, b$, x$
On Error GoTo errHandler
For r = 2 To Range("A" & Rows.Count).End(xlUp).Row
    a = Range("A" & r).Value
    b = Range("B" & r).Value
    Name a As b
    x = "Success"
skip:
    Range("G" & r) = x
 Next
Exit Sub

errHandler:
x = "Err " & Err.Description
On Error GoTo -1
On Error GoTo errHandler
GoTo skip
End Sub

And formatting my data to look like this instead:

284-406-20220721-08_01.pdf	C:\Destination\2118\284-406-20220721-08_01.pdf
298-297-20220720-09_02.pdf	C:\Destination\2134\298-297-20220720-09_02.pdf
320-319-20220728-08_07.pdf	C:\Destination\1645\320-319-20220728-08_07.pdf
C:\Source\352-351-20220805-12_57.pdf	C:\Destination\1427\352-351-20220805-12_57.pdf

While not ideal, I can make that work. The only issue is that it fails if the destination folder doesn't already exist. How can I make this check to see if the folder exists and create it if it doesn't?

Hi,

to check see the VBA function Dir and to create see function MkDir …

Another way which does all at once is the Windows function MakeSureDirectoryPathExists like you can find within this forum.

You are amazing! Thank you so much, that worked perfect.

Is there an easy way to add a popup once it's finished?

......................................
  'clean up
    Set fso = Nothing
    'Set srcFolder = Nothing
    Set dstFolder = Nothing
    msgbox "Completed file move."
End Sub