VBA macro to create pdf and folder based on cell values

[jjds1981]

Hello All,

I am fairly new to macros , and I am working on a project for work and would really appreciate any guidance. I am trying to create a new folder and PDF of the active sheet using specified cells for both the file name and folder name. My goal is that it would create the folder from the value in a given cell, and save the active sheet as a PDF from the value in a second cell into the newly created folder. There are instances where the folder name may have already been created in which case I would want the newly created PDF to go into the existing folder and not create a new one. I have started with some code, but I can only seem to get it to save the current workbook as an xls file not as a PDF. Any help would be much appreciated.


Sub PDFtoFolder()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Range("B9").Value ' New directory name


strFilename = Range("B11").Value 'New file name
strDefpath = "C:\Users\XXXX\Desktop\" 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub


MkDir strDefpath & strDirname
strPathname = strDefpath & strDirname & "\" & strFilename 'create total string


ActiveWorkbook.SaveAs Filename:=strPathname, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

[jolivanes]

Don't know which version of Excel you have but this should work in 2007 and up.

Sub Try_This_Maybe()
Dim myDir As String, mySht As String

myDir = "C:\" & ActiveSheet.Range("B9").Value
mySht = Range("B11").Value

On Error Resume Next
MkDir myDir
On Error GoTo 0

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myDir & "\" & mySht, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True '<---- or false
End Sub

[gmayor]

The following functions will create a new folder (the whole path in fact) on the user's desktop, if the folder if does not already exist, and will write the workbook to that folder. As you have used the user's desktop as a location (not the best place in my opinion, but no matter) I have included a standard function to determine the path of the user's Desktop. (The 64 bit part of the code I haven't tested, but it looks OK). What I haven't included is a function to check the values in the two cells for illegal filename characters, but it is a simple job to add that if your users can't be trusted to use only valid filename characters.


Option Explicit

#If Win64 Then
Public Declare PtrSafe Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hwnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Public Declare PtrSafe Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
#Else
Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hwnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Public Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
#End If

Public Const CSIDL_DESKTOP = &H0 'Desktop
Public Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Public Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Public Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Public Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Public Const CSIDL_PERSONAL = &H5 'My Documents
Public Const CSIDL_FAVORITES = &H6 '<user name>\Favorites
Public Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Public Const CSIDL_RECENT = &H8 '<user name>\Recent
Public Const CSIDL_SENDTO = &H9 '<user name>\SendTo
Public Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin
Public Const CSIDL_STARTMENU = &HB '<user name>\Start Menu
Public Const CSIDL_MYDOCUMENTS As Long = &HC
Public Const CSIDL_MYMUSIC As Long = &HD '"My Music" folder
Public Const CSIDL_MYVIDEO As Long = &HE '"My Videos" folder
Public Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop
Public Const CSIDL_DRIVES = &H11 'My Computer
Public Const CSIDL_NETWORK = &H12 'Network Neighborhood
Public Const CSIDL_NETHOOD = &H13 '<user name>\nethood
Public Const CSIDL_FONTS = &H14 'Windows\fonts
Public Const CSIDL_TEMPLATES = &H15
Public Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Public Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Public Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Public Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Public Const CSIDL_APPDATA = &H1A '<user name>\Application Data
Public Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood
Public Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)
Public Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Public Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Public Const CSIDL_COMMON_FAVORITES = &H1F
Public Const CSIDL_INTERNET_CACHE = &H20
Public Const CSIDL_COOKIES = &H21
Public Const CSIDL_HISTORY = &H22
Public Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Public Const CSIDL_WINDOWS = &H24 'Windows Directory
Public Const CSIDL_SYSTEM = &H25 'System Directory
Public Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Public Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Public Const CSIDL_PROFILE = &H28 'USERPROFILE
Public Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Public Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Public Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Public Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Public Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Public Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Public Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Public Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools
Public Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
Public Const CSIDL_COMMON_MUSIC As Long = &H35 'All Users\My Music
Public Const CSIDL_COMMON_PICTURES As Long = &H36 'All Users\My Pictures
Public Const CSIDL_COMMON_VIDEO As Long = &H37 'All Users\My Video
Public Const CSIDL_RESOURCES As Long = &H38 'Resource Directory
Public Const CSIDL_RESOURCES_LOCALIZED As Long = &H39 'Localized Resource Directory
Public Const CSIDL_COMMON_OEM_LINKS As Long = &H3A 'Links to All Users OEM specific apps
Public Const CSIDL_CDBURN_AREA As Long = &H3B 'USERPROFILE\Local Settings\Application Data\Microsoft\CD Burning
'unused As Long = &H3C
Public Const CSIDL_COMPUTERSNEARME As Long = &H3D 'Computers Near Me (computered from Workgroup membership)

Public Const MAX_PATH = 260
Public Const NOERROR = 0


Public Sub SaveWorkBook()
Dim strFilename As String, strDirname As String
Dim strPathname As String, strDefpath As String
strDefpath = SpecFolder(&H0) 'Default path name

If Range("B9").Value = "" Then
MsgBox "There is no value for the folder?"
Exit Sub
End If
If Range("B11").Value = "" Then
MsgBox "There is no value for the filename?"
Exit Sub
End If

strDirname = Trim(Range("B9").Value) ' New directory name
strFilename = Trim(Range("B11").Value) 'New file name
strPathname = strDefpath & "\" & strDirname 'Create the full path
CreateFolders strPathname
strFilename = strPathname & strFilename 'create total string
MsgBox strFilename
ActiveWorkbook.SaveAs Filename:=strFilename, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
lbl_Exit:
Exit Sub
End Sub


Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
lbl_Exit:
Exit Function
End Function

Public Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Public Function FolderExists(ByVal PathName As String) As Boolean
Dim lngAttr As Long
On Error GoTo NoFolder
lngAttr = GetAttr(PathName)
If (lngAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
Exit Function
End Function

[snb]

This should be sufficient:


Sub M_snb()
On Error Resume Next
c00 = CreateObject("wscript.shell").specialfolders("Desktop") & "\" & Sheet1.Range("B9")
MkDir c00

ActiveWorkbook.ExportAsFixedFormat 0, c00 & "\" & Sheet1.Range("B11")
End Sub

[jjds1981]

jolivanes,

Thanks for the help! I am using excel 2010 and the code worked perfectly. I was also able to get the previous code I posted to work with a few changes, but your code seems to be cleaner than mine. I was hoping to see if anyone might be able to help me take this another step forward. The PDF that this is creating is a commission statement. When I select the employee number out of a drop down list the excel sheet, excel loads that employees information based upon formulas in the sheet. I then run the macro to create the PDF and save it to to appropriate folder. Is there a way to set this macro up so that the macro will select the employees in the list rather than me clicking them one at a time and running the macro. Per say it would select the first employee in the list...information will load...saves as the PDF to appropriate folder, then selects the second employee from list...information loads...saves PDF to folder.......on down the list for all employees? Thanks again for your help!!!

[snb]

Where does the list reside in your Excel Workbook ?

[jjds1981]

The cell with the drop down inside of it is on sheet1, but the list for the dropdown is on sheet2 within the same workbook. Thanks.

[jolivanes]

And where is the information pertaining to each individual stored?

[jjds1981]

The formulas that display the information are on sheet1 but the information is pulled in from sheet 2. Sheet 1 is the statement that gets saved as the pdf.

[jolivanes]

I think I understand that part but how do the formulae change the information?
If you export Sheet1 to PDF without changing anything in Sheet1, all the PDF files are going to be the same.
Walk us through the sequence of doing things manually.

[snb]

if the 'list' is in sheet2 Range A1:20
and if cell B11 in sheet1 contains that list:

Sub M_snb()
On Error Resume Next
sn=sheet2.range("A1:A20")
c00 = CreateObject("wscript.shell").specialfolders("Desktop") & "\" & Sheet1.Range("B9")
MkDir c00

for j=1 to ubound(sn)
sheet1.range("B11").value=sn(j,1)
sheet1.ExportAsFixedFormat 0, c00 & "\" & Sheet1.Range("B11")
next
End Sub

[jolivanes]

When I select the employee number out of a drop down list the excel sheet, excel loads that employees information based upon formulas in the sheet.
This number needs to do somewhere in Sheet1 I assume for the formulae to work
In the below code it copies into Cell B11 on Sheet1
The name of the Folder to be created is in Sheet2, Cell G1
The list with Employee Numbers is in Sheet2 Column H Starting at Cell H1



Sub Try_This_Maybe_Multiple()
Dim myDir As String, c As Range
myDir = "C:\" & Sheets("Sheet2").Range("G1").Value
On Error Resume Next
MkDir myDir
On Error GoTo 0
For Each c In Sheets("Sheet2").Range("H1:H" & Sheets("Sheet2").Cells(Rows.Count, 8).End(xlUp).Row)
Sheets("Sheet1").Range("B11").Value = c.Value '<---- Change reference to where the employee number goes
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myDir & "\" & c.Value, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False '<---- or True
Next c
End Sub

If this is not what you want, attach a mock file where everything relates as in your original workbook

[jjds1981]

Sheet1 is a template and sheet2 is a data dump with all employees, salary, sales, commission, etc. When I select the employee ID on sheet1 from the dropdown there are a bunch of v lookups on on sheet 1 that pull in that employees specific numbers, name, etc. I then would save sheet1 as a PDF and select the next employee ID from the dropdown until I have saved a statement for each employee. Please let me know if you need me to explain any more. Thanks again for all of the help!

[jolivanes]

OK, that makes sense (I think)
So if, instead of using a dropdown in Sheet1 we could copy the employee ID into that cell so the VLookups work. Right.
You could also collect all the relative information for each Employee ID from Sheet2 and paste it in Sheet1 programmatically.
In the code in Post 12 this is Cell B11. If you change that to the dropdown cell, does it then work? (You might have to delete the dropdown in Sheet1)
And where are the Employee ID's? In the last code I used Column H in Sheet2 as I did not know (and still don't know) where that list is.

[jjds1981]

Sorry for the late reply...things have been crazy busy. Thanks for the suggestions! I have it almost working using the code that snb provided. It runs through the range of employee ID's and creates the correct PDF's, but it is only creating 1 folder on my desktop with all of the files in it. A better break down of how things are setup....Basically the employee ID (Cell B10 Sheet 1) triggers the information to be pulled, the file name is the employees name (Cell B11 sheet 1), and the folder that it should be saved into on my desktop is the managers name (cell B9 sheet 1) - This can possibly change with each different employee ID. My goal is for it to create all of the PDF's for each employee (it is doing this already), and then save each of those PDF's to their respective managers folders on the desktop. If the folder is not there then I would need it to create it. jolivanes your first code worked perfectly, but the multiple code would only create 1 pdf and 1 folder. Also the range of employee ID's are in sheet 2 A:3-A:300. I have posted my current code below. Any further ideas would be extremely helpful! Thanks again!

Sub M_snb()
On Error Resume Next
sn = Sheets("AIP 2014 Sal Inc & Target %").Range("A3:A300")
c00 = CreateObject("wscript.shell").specialfolders("Desktop") & "\" & Sheets("Stmt Template for AIP+Equity").Range("B9")
MkDir c00

For j = 1 To UBound(sn)
Sheets("Stmt Template for AIP+Equity").Range("B10").Value = sn(j, 1)
Sheets("Stmt Template for AIP+Equity").ExportAsFixedFormat 0, c00 & "\" & Sheets("Stmt Template for AIP+Equity").Range("B11") & ".pdf", 0, 1, 0, , , 0
Next
End Sub

[jjds1981]

jolivanes,

This is what I have with your code so far as well....It will only create one folder and file, but acts like it is running through the names when the macro is running.

Sub Try_This_Maybe()
Dim myDir As String, myDirSub As String, mySht As String, c As Range

myDir = "C:\Users\UJOSPAL\Desktop\" & ActiveSheet.Range("B9").Value
myDirSub = myDir & "\" & ActiveSheet.Range("B12").Value
mySht = Range("B11").Value

On Error Resume Next
MkDir myDir
MkDir myDirSub
On Error GoTo 0

For Each c In Sheets("AIP 2014 Sal Inc & Target %").Range("A3:A" & Sheets("AIP 2014 Sal Inc & Target %").Cells(Rows.Count, "A").End(xlUp).Row)
Sheets("Stmt Template for AIP+Equity").Range("B10").Value = c.Value
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myDirSub & "\" & mySht, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False '<---- or false
Next
End Sub

Thanks!

[jolivanes]

All the information is on Sheet1 if I read your last post correct.
If the Employee ID is pasted into Cell B10 on Sheet1, does that trigger all the changes like manager's name etc?
If not, you'll end up with a bunch of Sheets with the same information on all of them.

[snb]

Please use code tags !


Sub M_snb()
On Error Resume Next
c00=CreateObject("wscript.shell").specialfolders("Desktop")

sn = Sheets("AIP 2014 Sal Inc & Target %").Range("A3:A300")

For j = 1 To UBound(sn)
With Sheets("Stmt Template for AIP+Equity")
.Range("B10").Value = sn(j, 1)
mkdir c00 & "\" & .Range("B9")
.ExportAsFixedFormat 0, c00 & "\" & .Range("B9") & "\" & .Range("B11") & ".pdf"
end with
Next
End Sub

[jjds1981]

my apologies! snb the code worked perfectly, thank you so much!! I hate to ask but is it possible to go one step further and create a sub folder within the directory based on a cell value.

Directory (Cell Value B9) -> Sub Directory (Cell Value B12) -> PDF's Created (Cell Value B11)

Thank you again for all of the help!!