Copying PDFs to a dynamic folder path

[gznuk]

Hello,

I've been trying to figure out this task most of today, and I'd love to get some feedback/advice.

I have 2 columns of information. Column B has the names of several PDF documents and Column C has descriptions of what each of those PDFs are. Currently, all the PDF files are in one massive folder, but I would like to create folders (based on the descriptions in column C) and put assign the PDFs to the newly created folders.

I was able to Frankenstein a few pieces of code together to create these new folders. With how the descriptions are written in column C, I had to use a Left() function to extract the 10 left characters of text to create my folders. This code (see below, and I know it is quite messy), has allowed me to create those folders, and move the PDFs from one from folder to another, but not to the appropriately named folder. PDF names line up with the appropriate folder on the spreadsheet, so I would need B1 to go in folder left(C1,10).


Option Explicit


Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim TestStr As String
Dim bContinue As Boolean
Dim sPathFrom As String
Dim sPathTo As String
Dim sFile As String

Dim cell As Range
Dim sourceRange As Range

Columns("C:C").Select
Set sourceRange = Range(Sheets("Sheet1").Range("C1:C1000"), Selection.End(xlDown))

For Each cell In sourceRange
If IsEmpty(cell.Value) Then Exit For
MkDir "C:\Users\####\Desktop\Mentone\Panel Drawings" & Left$(cell.Value, 10)
On Error Resume Next
Next

bContinue = True
iRow = 2

sSourcePath = "C:\Users\####\Desktop\Mentone\Latest Drawings"
sDestinationPath = "C:\Users\####\Desktop\Mentone\Panel Drawings"

sFileType = ".pdf"

While bContinue

If Len(Range("B" & CStr(iRow)).Value) = 0 Then
MsgBox "Process executed" ' DONE.
bContinue = False
Else

If Len(Dir(sSourcePath & Range("B" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("C" & CStr(iRow)).Value = "Does Not Exists"
Range("C" & CStr(iRow)).Font.Bold = True
Else
Range("C" & CStr(iRow)).Value = "On Hand"
Range("C" & CStr(iRow)).Font.Bold = False

If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")

If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If

objFSO.CopyFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath

End If
End If
End If

iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub



I need help getting the files in the appropriate folders because this a repetitive task and becomes quite time consuming with several hundred documents.