So I found this code which loops through and opens up a url for every address that is listed in Column C (starting with row 8 and then saves it according to the folder location that is listed in cell B4. Each file is named according to the name which is in the column right next to it. So for example if I have 3 url addresses listed in rows 8,9, and 10 then I will end up with 3 saved web pages all saved in the folder identified in cell B4.
So what I am trying to do is to give each URL a different file location to be saved to. So instead of saving all pages to the same folder it will be saved to individual folders. I would like to use Column B as the location for the folder addresses.
Does anyone know how to help with this?
Sub URLToPDF()
'Loops throuhg all the urls at column C and print the web
'pages as PDF using Adobe Professional.
'This is the main sub that calls the rest subs.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim PDFFolder As String
Dim LastRow As Long
Dim arrSpecialChar() As String
Dim dblSpCharFound As Double
Dim PDFPath As String
Dim i As Long
Dim j As Integer
'An array with special characters that cannot be used for naming a file.
arrSpecialChar() = Split("\ / : * ? " & Chr$(34) & " < > |", " ")
'Find the last row.
With Worksheets("Main")
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
'Check if the PDF's folder exists.
PDFFolder = Worksheets("Main").Range("B4").Value
If FolderExists(PDFFolder) = False Or PDFFolder = "" Then
MsgBox "The PDF folder's path is incorect!", vbCritical, "Wrong path"
Worksheets("Main").Range("B4").Select
Exit Sub
End If
'Check if there is at least one URL.
If LastRow < 8 Then
MsgBox "You did't enter a URL!", vbCritical, "No URL"
Exit Sub
End If
'Add the backslash if not exists.
If Right(PDFFolder, 1) <> "\" Then
PDFFolder = PDFFolder & "\"
End If
'Convert the URLs to PDFs.
For i = 8 To LastRow
On Error Resume Next
PDFPath = Cells(i, 4).Value
'Check if the PDF name contains a special/illegal character.
For j = LBound(arrSpecialChar) To UBound(arrSpecialChar)
dblSpCharFound = WorksheetFunction.Find(arrSpecialChar(j), PDFPath)
If dblSpCharFound > 0 Then
PDFPath = WorksheetFunction.Substitute(PDFPath, arrSpecialChar(j), "-")
End If
Next j
PDFPath = PDFFolder & PDFPath
On Error GoTo 0
'Save the PDF files to the selected folder.
Call WebpageToPDF(Cells(i, 3).Value, PDFPath & ".pdf")
Next i
'Inform the user that macro finished.
MsgBox LastRow - 7 & " web pages were successfully saved as PDFs!", vbInformation, "Done"
End Sub
Bookmarks