Print to PDF

[javierhero2324]

Hi I want to create a macro to allow me to print to pdf for each individual state

I want to click and create 50 different pdf with there own information
ex.

State CA TX NV NM NY NJ etc
Population
Average Age
Males
Females

Thanks

 

[Logit]

.
I don't completely understand your goal but here is a macro to save the designated range
as a PDF in the same folder as the workbook :

Option Explicit

Sub Export_Worksheet_to_PDF()

    Dim mypath As String, fname As String
    mypath = ThisWorkbook.Path
    fname = CreateObject("Scripting.FileSystemObject").GetBaseName(ThisWorkbook.Name)
    ActiveSheet.Range("A1:I47").ExportAsFixedFormat 0, mypath & "\" & fname
    '           ^^^^^^^^^^^^^^^^
    '           ^^^^^^^^^^^^^^^^
    ' Change the above range to cover the PRINT RANGE only.
    
    'Saves the PRINT RANGE as a PDF in the same folder as this workbook.

End Sub

 

[javierhero2324]

My goal is to be able to print each state information into their individual pdf and not have to go one by one. I need to create 50 different pdf each week to distribute to there according offices in each state. Looking for a macro to save me sometime.

Hope this helps
Thanks a lot

 

[Logit]

Please understand that you can visualize what it is you have before you. How your workbook is designed, what rows / columns are
utilized, the formatting, etc.

Additional information is needed to accurately provide an answer. Posting a copy of your workbook would be beneficial.

Thank you for your understanding.

 

[javierhero2324]

Hope this helps.
Really appreciate your time

 

[Logit]

Paste the following into a Regular Module. Paste a command button on the sheet named "ALL"
and connect it to this macro.

Option Explicit

Sub sbColumnsToSheets2()
  ' Purpose: Create a separate worksheet for each column in your selection
  ' the name of the sheet will be the name of the first row in each column.

  ' Usage:
  ' first select the cells then run this macro


  Dim rngSelection                                     As Range
  Dim wsStart                                          As Worksheet
  Dim wsNew                                            As Worksheet
  Dim lRowLast                                         As Long
  Dim lCollast                                         As Long
  Dim lRowFirst                                        As Long
  Dim lColFirst                                        As Long
  Dim lCol                                             As Long
  Dim strSheetName                                     As String
  Dim fnUniqueSheetName

  On Error GoTo sbColumnsToSheets_Error

  Application.ScreenUpdating = False

  Set wsStart = ActiveSheet
  Set rngSelection = wsStart.Range("B4:AY10")
  lRowFirst = rngSelection.Cells(1).Row
  lColFirst = rngSelection.Cells(1).Column
  lRowLast = rngSelection.Cells(rngSelection.Cells.Count).Row
  lCollast = rngSelection.Cells(rngSelection.Cells.Count).Column
    
  ' loop through the columns
  For lCol = lColFirst To lCollast
    
    ' add a new sheet at the end
    ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count), Type:=xlWorksheet
    
    Set wsNew = ActiveSheet

    ' copy the column from the original sheet
    wsStart.Activate
    
    wsStart.Range("A1:A10").Copy
    wsNew.Range("A1").PasteSpecial Paste:=xlPasteValues
    wsNew.Paste
    
    wsStart.Range(Cells(lRowFirst, lCol), Cells(lRowLast, lCol)).Copy
    wsNew.Range("B4").PasteSpecial Paste:=xlPasteValues
    wsNew.Paste
    
    wsNew.Range("C4:C10").Value = wsStart.Range("AZ4:AZ10").Value
    wsNew.Range("C4").Font.Bold = True
    
    wsNew.Columns("A:F").AutoFit
    Application.CutCopyMode = False
    wsNew.Name = wsNew.Range("B4").Value

  Next lCol

  wsStart.Activate
  Application.ScreenUpdating = True
  Application.StatusBar = False

  On Error GoTo 0
  Exit Sub

sbColumnsToSheets_Error:
  Application.ScreenUpdating = True
  Application.StatusBar = False
  MsgBox "Error " & Err.Number & " (" & Err.Description & ")" & _
         "in procedure sbColumnsToSheets", vbCritical
End Sub


Private Function fnUniqueSheetName2(strName As String) As String
  ' Loop through all sheets and see if the name already exists
  ' if is does, add a number to the name and check again.
  ' Repeat until a unique name is found
  ' The maximum length for a sheetname is 31 characters.

  Dim objSheet                                         As Object
  Dim strNewName                                       As String
  Dim i                                                As Long
  ' Certain characters are not allowed in a sheet's namea:
  strName = Replace(strName, ":", "_")
  strName = Replace(strName, "\", "_")
  strName = Replace(strName, "/", "_")
  strName = Replace(strName, "?", "_")
  strName = Replace(strName, "*", "_")
  strName = Replace(strName, "[", "_")
  strName = Replace(strName, "]", "_")
  strNewName = strName
  i = 1
  If Len(strNewName) > 31 Then
    strNewName = Left(strNewName, 21) & ".." & Right(strNewName, 8)
  End If

Start:

  For Each objSheet In ActiveWorkbook.Sheets
    If objSheet.Name = strNewName Then
      strNewName = strName & " (" & i & ")"
      If Len(strNewName) > 31 Then
        strNewName = Left(strNewName, 21) & ".." & Right(strNewName, 8)
      End If
      i = i + 1
      GoTo Start
      Exit For
    End If
  Next

  fnUniqueSheetName = strNewName

End Function