Copying PDFs to a dynamic folder path

gznuk

New Member
Joined
Apr 30, 2018
Messages
1
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.
 

Some videos you may like

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

Watch MrExcel Video

Forum statistics

Threads
1,123,217
Messages
5,600,376
Members
414,380
Latest member
p1electric

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top