Macro to create a unique folder name, save file, and print a PDF based on cell value

[banderson7563]

I currently use a spreadsheet to create all my quotes for my customers. Overall I have it pretty clean and quick, but one thing that can save me time is being able to automate creating a folder, saving the file, and printing a PDF to email to the customer. All formats are the same for the quote, so the names are being pulled in from the same spot. My goal is for this macro to:
1. create a new folder in C:\Users\myname\My Files\Quotes - the name for the this file would pull from two spots on the sheet and be "B3 - A19". an example of what this would look like would be "ABC Company - XYZ System"
2. Save the workbook in this newly created folder as "Quote - B3" so in the example above it would be "Quote - ABC Company"
3. Create a PDF saved in the newly created folder with the same name as the workbook - "Quote - B3" so in the example it would be "Quote - ABC Company"

Any help or ideas would be great! Thanks in advance

 

[DanteAmor]

Hi and welcome to MrExcel.

Try this:

Sub macro()
  Dim d1 As String, d2 As String, sPath As String
  Dim wb As Workbook
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Sheets("Sheet1")
    d1 = .Range("B3")
    d2 = .Range("A19")
  End With
  
  sPath = Environ$("userprofile") & "\My Files"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes\" & d1 & " - " & d2
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  
  Sheets.Copy
  Set wb = ActiveWorkbook
  wb.SaveAs sPath & "\" & "Quote - " & d1, FileFormat:=xlOpenXMLWorkbook
  wb.ExportAsFixedFormat xlTypePDF, sPath & "\" & "Quote - " & d1 & ".pdf", _
      xlQualityStandard, True, False, OpenAfterPublish:=False
  wb.Close False
End Sub

 

[banderson7563]

Hi and welcome to MrExcel.

Try this:

Sub macro()
  Dim d1 As String, d2 As String, sPath As String
  Dim wb As Workbook
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Sheets("Sheet1")
    d1 = .Range("B3")
    d2 = .Range("A19")
  End With
 
  sPath = Environ$("userprofile") & "\My Files"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes\" & d1 & " - " & d2
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
 
  Sheets.Copy
  Set wb = ActiveWorkbook
  wb.SaveAs sPath & "\" & "Quote - " & d1, FileFormat:=xlOpenXMLWorkbook
  wb.ExportAsFixedFormat xlTypePDF, sPath & "\" & "Quote - " & d1 & ".pdf", _
      xlQualityStandard, True, False, OpenAfterPublish:=False
  wb.Close False
End Sub

You are amazing! One thing I need adjusted. Currently this make a multi page PDF with every tab I have. If I only want the PDF to be the 3rd tab which is titled "Customer Quote" what do I need to change?

 

[banderson7563]

You are amazing! One thing I need adjusted. Currently this make a multi page PDF with every tab I have. If I only want the PDF to be the 3rd tab which is titled "Customer Quote" what do I need to change?

@DanteAmor one more thing I just ran into while testing this out. Can I put in errors or something along those lines that would put a stop to this if the Folder and File name already exist? Sorry I did not think of that ahead of time. I just want to make sure I don't accidently overwrite a folder or file.

 

[DanteAmor]

If I only want the PDF to be the 3rd tab which is titled "Customer Quote"

Only that sheet for the pdf.

I just want to make sure I don't accidently overwrite a folder or file.

Only the file can be overwritten. I put a warning in case the file already exists.

Sub macro()
  Dim d1 As String, d2 As String, sPath As String, sName As String
  Dim wb As Workbook
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Sheets("Sheet1")
    d1 = .Range("B3")
    d2 = .Range("A19")
  End With
  
  sPath = Environ$("userprofile") & "\My Files"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes\" & d1 & " - " & d2
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  
  sName = sPath & "\" & "Quote - " & d1
  If Dir(sName & "*") <> "" Then
    If MsgBox("File name already exist: " & vbCr & _
      sName & vbCr & "Overwrite?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
  End If
  Sheets.Copy
  Set wb = ActiveWorkbook
  wb.SaveAs sName, FileFormat:=xlOpenXMLWorkbook
  wb.Sheets("Customer Quote").ExportAsFixedFormat xlTypePDF, sName & ".pdf", xlQualityStandard, True, False, OpenAfterPublish:=False
  wb.Close False
End Sub

 

[banderson7563]

@DanteAmor one more thing I just ran into while testing this out. Can I put in errors or something along those lines that would put a stop to this if the Folder and File name already exist? Sorry I did not think of that ahead of time. I just want to make sure I don't accidently overwrite a folder or file.

Only that sheet for the pdf.


Only the file can be overwritten. I put a warning in case the file already exists.

Sub macro()
  Dim d1 As String, d2 As String, sPath As String, sName As String
  Dim wb As Workbook
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Sheets("Sheet1")
    d1 = .Range("B3")
    d2 = .Range("A19")
  End With
 
  sPath = Environ$("userprofile") & "\My Files"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes"
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  sPath = Environ$("userprofile") & "\My Files\Quotes\" & d1 & " - " & d2
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
 
  sName = sPath & "\" & "Quote - " & d1
  If Dir(sName & "*") <> "" Then
    If MsgBox("File name already exist: " & vbCr & _
      sName & vbCr & "Overwrite?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
  End If
  Sheets.Copy
  Set wb = ActiveWorkbook
  wb.SaveAs sName, FileFormat:=xlOpenXMLWorkbook
  wb.Sheets("Customer Quote").ExportAsFixedFormat xlTypePDF, sName & ".pdf", xlQualityStandard, True, False, OpenAfterPublish:=False
  wb.Close False
End Sub

This works per Thanks again!

 

[banderson7563]

This works per Thanks again!

Perfect* not sure what happened there.

 

[banderson7563]

@DanteAmor I feel bad for keeping you coming back to this. Thank you for all the help so far, it's been amazing! One last thing I just ran into - when the new workbook is made and saved is there a way for the code to now go with that new workbook. I had to make an adjustment on a quote, and when I ran the code, it went back to my original document rather than the newly saved one.

For example - my macro is saved in a file titled - "Customer Quote Template". Once my info is entered for the new customer I run the macro and my new file is saved as "Quote - ABC Company". I needed to make a small change on my "Quote - ABC Company" spreadsheet and when I click the button to run the macro it reopened the "Customer Quote Template" and ran from there without the change I made.

Is there a way to fix this?

 

[DanteAmor]

I do not understand what do you need. But try the following to see if it helps.
Change this line:

wb.SaveAs sName, FileFormat:=xlOpenXMLWorkbook

For this:

ThisWorkbook.SaveCopyAs sName

 

[banderson7563]

I do not understand what do you need. But try the following to see if it helps.
Change this line:

wb.SaveAs sName, FileFormat:=xlOpenXMLWorkbook

For this:

ThisWorkbook.SaveCopyAs sName

I am wanting the Macro to be in the newly saved file and not in the original template file. This does not save the new file as an excel spreadsheet.