VBA Code to Move 5000 PDF's into subfolders

[bergman99]

Hi folks!

I've got a folder that has 5000+ pdf's in it. I've got a spreadsheet as shown below. I'd like to run a sub that copies the pdf's in the original folder and pastes them into the new folder..

Is anyone able to help?

PDF Name	PDF Type	Current Folder	Copy to New Folder
pdf001	Type 1	C:\MyPDFFolder\	C:\MyPDFFolder\Type1\
pdf002	Type 2	C:\MyPDFFolder\	C:\MyPDFFolder\Type2\
pdf003	Type 3	C:\MyPDFFolder\	C:\MyPDFFolder\Type3\
pdf004	Type 1	C:\MyPDFFolder\	C:\MyPDFFolder\Type4\

<tbody>
</tbody>

Thanks!!

 

[sericom]

How do you determine which Type a PDF file is, or do you want 5000 Type folders.

 

[bergman99]

How do you determine which Type a PDF file is, or do you want 5000 Type folders.

Thanks for the reply! The types are already assigned, there's appx 200.

 

[Macropod]

But precisely where is the code supposed to get the Type data from? Do the destination folders already exist? Also, how are these PDFs being created? If they're being created from the workbook using the macro, why not create them in the destination folders in the first place? Finally, are the files being moved or copied?

 

[bergman99]

The spreadsheet is complete, the PDF type, current folder and new folder are already populated. The PDF's already exist in the current folder, all 5000 of them. I would like the code to copy the PDF from the "current folder" location into the folder specified in the "Copy to New Folder" column..

Does that make sense?

 

[bergman99]

One more thing, the type folders exist as well..

 

[John_w]

Try this:

Public Sub Copy_Files()

    Dim lr As Long, r As Long
    
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    For r = 2 To lr
        FileCopy Cells(r, 3).Value & Cells(r, 1).Value & ".pdf", Cells(r, 4).Value & Cells(r, 1).Value & ".pdf"
    Next
    
    MsgBox "Done"
    
End Sub

 

[bergman99]

So unbelievably simple in appearance. Works absolutely perfectly. Thank you very much!!

 

[Macropod]

Try:

Sub CopyPDFs()
Dim i As Long, StrNm As String
Const StrFldSrc As String = "C:\MyPDFFolder\"
With ActiveSheet.UsedRange
  For i = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
    Application.StatusBar = "Copying File " & i
    StrNm = .Cells(i, 1).Value & ".pdf"
    FileCopy StrFldSrc & StrNm, .Cells(i, 4).Text & StrNm
  Next
End With
Application.StatusBar = False
MsgBox "Done", vbExclamation
End Sub

This one gives a progress report as well.