VBA - Trying to move PDFs to Multiple File Paths

[Alex Link]

****** id="cke_pastebin" style="position: absolute; top: 0px; width: 1px; height: 1px; overflow: hidden; left: -1000px;"><article>

I am "new-ish" with Macros... I am working on getting about 300 PDFs renamed and moved into appropriate folders.

I have macros set-up to get the file names, rename the files and create folders, but I can not figure out how to move or copy the files based on the file path that I have indicated for the specific PDF. Everything I find online shows moving files from one folder to another, but I need to move these PDFs from 1 folder into 300 uniquely named folders.

I need something that can tell excel to Move Files (or copy files) , current path (or xDir) I want to set to "C:" for a prompt to choose a folder and I want to set the file names (from column B) to be SelectedItems and then move or copy to the folder path that I have indicated in Column C.

My spreadsheet is set-up as shown below (current folder path = Desktop)

Column A=Old File Name (ran macro "GetFiles")
- i.e. Reg 123 Survey Reprt October.pdf
Column B=New File Name (ran Macro "RenameFiles"
- i.e. October Survey - Region 123.pdf
Column C = new folder path (each "region" has it's own folder)
- i.e. C:\Reports\October\Region 123
C:\Reports\October\Region 234
C:\Reports\October\Region 467​

</article>


</body>
<article>

I am "new-ish" with Macros... I am working on getting about 300 PDFs renamed and moved into appropriate folders.

I have macros set-up to get the file names, rename the files and create folders, but I can not figure out how to move or copy the files based on the file path that I have indicated for the specific PDF. Everything I find online shows moving files from one folder to another, but I need to move these PDFs from 1 folder into 300 uniquely named folders.

I need something that can tell excel to Move Files (or copy files) , current path (or xDir) I want to set to "C:" for a prompt to choose a folder and I want to set the file names (from column B) to be SelectedItems and then move or copy to the folder path that I have indicated in Column C.

My spreadsheet is set-up as shown below (current folder path = Desktop)

Column A=Old File Name (ran macro "GetFiles")
- i.e. Reg 123 Survey Reprt October.pdf
Column B=New File Name (ran Macro "RenameFiles"
- i.e. October Survey - Region 123.pdf
Column C = new folder path (each "region" has it's own folder)
- i.e. C:\Reports\October\Region 123
C:\Reports\October\Region 234
C:\Reports\October\Region 467​

</article>

 

[John_w]

Welcome to MrExcel forums.

Try this macro, which includes code to copy or move the files. As written, the code copies the files, since that is safer than moving them. To move the files instead, just delete or comment out the FileCopy line and uncomment the Dir and Name lines.

Public Sub Copy_Selected_Files_To_Folder()

    Dim fd As FileDialog
    Dim sourceFolder As String
    Dim columnBcell As Range
    
    If Selection.Column <> 2 Then
        MsgBox "No cells in column B are selected"
        Exit Sub
    End If
    
    sourceFolder = ""
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select source folder"
        .AllowMultiSelect = False
        .InitialFileName = "C:\"
        If .Show Then sourceFolder = .SelectedItems(1)
    End With

    If sourceFolder <> "" Then
        For Each columnBcell In Selection
            If Dir(sourceFolder & "\" & columnBcell.Offset(, -1)) <> "" Then
                'Copy file (overwrites destination file if it already exists)
                FileCopy sourceFolder & "\" & columnBcell.Offset(, -1), columnBcell.Offset(, 1).Value & "\" & columnBcell.Value
                
                'Move file
                'If Dir(columnBcell.Offset(, 1).Value & "\" & columnBcell.Value) <> "" Then Kill columnBcell.Offset(, 1).Value & "\" & columnBcell.Value  'delete destination file if it already exists
                'Name sourceFolder & "\" & columnBcell.Offset(, -1) As columnBcell.Offset(, 1).Value & "\" & columnBcell.Value
            End If
        Next
    End If

End Sub