Advertisement
shaashwato1308

EXCEL MACROS: Save active sheet as PDF

Oct 13th, 2019
111
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 1.52 KB | None | 0 0
  1. Sub PDFActiveSheet()
  2. 'www.contextures.com
  3. 'for Excel 2010 and later
  4. Dim wsA As Worksheet
  5. Dim wbA As Workbook
  6. Dim strTime As String
  7. Dim strName As String
  8. Dim strPath As String
  9. Dim strFile As String
  10. Dim strPathFile As String
  11. Dim myFile As Variant
  12. On Error GoTo errHandler
  13.  
  14. Set wbA = ActiveWorkbook
  15. Set wsA = ActiveSheet
  16. strTime = Format(Now(), "yyyymmdd\_hhmm")
  17.  
  18. 'get active workbook folder, if saved
  19. strPath = wbA.Path
  20. If strPath = "" Then
  21. strPath = Application.DefaultFilePath
  22. End If
  23. strPath = strPath & "\"
  24.  
  25. 'replace spaces and periods in sheet name
  26. strName = Replace(wsA.Name, " ", "")
  27. strName = Replace(strName, ".", "_")
  28.  
  29. 'create default name for savng file
  30. strFile = strName & "_" & strTime & ".pdf"
  31. strPathFile = strPath & strFile
  32.  
  33. 'use can enter name and
  34. ' select folder for file
  35. myFile = Application.GetSaveAsFilename _
  36. (InitialFileName:=strPathFile, _
  37. FileFilter:="PDF Files (*.pdf), *.pdf", _
  38. Title:="Select Folder and FileName to save")
  39.  
  40. 'export to PDF if a folder was selected
  41. If myFile <> "False" Then
  42. wsA.ExportAsFixedFormat _
  43. Type:=xlTypePDF, _
  44. Filename:=myFile, _
  45. Quality:=xlQualityStandard, _
  46. IncludeDocProperties:=True, _
  47. IgnorePrintAreas:=False, _
  48. OpenAfterPublish:=True
  49. 'confirmation message with file info
  50. MsgBox "PDF file has been created: " _
  51. & vbCrLf _
  52. & myFile
  53. End If
  54.  
  55. exitHandler:
  56. Exit Sub
  57. errHandler:
  58. MsgBox "Could not create PDF file"
  59. Resume exitHandler
  60. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement