Using VBA to print to PDF existing macro - excel

So i found this code online and was able to edit it to do what i want EXCEPT save as a PDF it currently set to only show me a print preview. Can someone explain how to edit this to save as a PDF with the File name being what ends up appearing in cell "A2"
Sub testme()
Dim TempWks As Worksheet
Dim wks As Worksheet
Dim myRng As Range
Dim myCell As Range
'change to match your worksheet name
Set wks = Worksheets("Sheet3")
Set TempWks = Worksheets.Add
wks.AutoFilterMode = False 'remove the arrows
'assumes headers only in row 1
wks.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), Unique:=True
With TempWks
Set myRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With wks
For Each myCell In myRng.Cells
.UsedRange.AutoFilter Field:=1, Criteria1:=myCell.Value
Dim MyFileName As Variant
Dim MyfilePath As Variant
Dim rng As Range
Set wks = Worksheets("Sheet3")
Set rng = wks.Cells(2, 1)
MyfilePath = "C:\Users\mmunoz\Desktop\Teresa" 'this is whatever location you wish to save in
MyFileName = MyfilePath & "\" & rng.Value & ".pdf" 'You can do the below in just a couple of lines, but this is way more effective and stops issues later on
ChDir _
MyfilePath ' hold your save location
wks.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'did you want to open the file after saving?
Next myCell
End With
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
End Sub
I have a bunch of data that I need to filter to show only a client's lines of data and save that as a PDF to send to the client.
Thanks,

This is the gist of what you want. I've added comments to explain
Dim MyFileName As Variant
Dim MyfilePath As Variant
Dim rng As Range
Set rng = wks.Cells(2, 1)
MyfilePath = "N:\Desktop" 'this is whatever location you wish to save in
MyFileName = MyfilePath & "\" & rng.Value & ".pdf" 'You can do the below in just a couple of lines, but this is way more effective and stops issues later on
ChDir _
MyfilePath ' hold your save location
wks.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True 'did you want to open the file after saving?

Option Explicit
Sub testme()
Dim TempWks As Worksheet
Dim wks As Worksheet
Dim myRng As Range
Dim myCell As Range
'change to match your worksheet name
Set wks = Worksheets("Sheet3")
Set TempWks = Worksheets.Add
wks.AutoFilterMode = False 'remove the arrows
'assumes headers only in row 1
wks.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), Unique:=True
With TempWks
Set myRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With wks
For Each myCell In myRng.Cells
.UsedRange.AutoFilter Field:=1, Criteria1:=myCell.Value
Dim MyFileName As Variant
Dim MyfilePath As Variant
Dim rng As Range
Set rng = wks.Cells(2, 1)
MyfilePath = "C:\Users\mmunoz\Desktop\Teresa" 'File Location
MyFileName = MyfilePath & "\" & myCell.Value & ".pdf" 'File Name
ChDir _
MyfilePath
wks.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next myCell
End With
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
End Sub

Related

Combine Multiple Ranges in one pdf

On the basis of a few posts I was able to make below script which prints several selected ranges to a pdf file. However, all ranges are printed on a seperate sheet.
Currently NewRng.Address="A1:G9,A13:G14,A18:G37". I think it might need to be "A1:G9;A13:G14;A18:G37" (seperated by ; instead of ,)(?)
Can someone explain how can I print the selected ranges on one sheet?
Thank you so much!
Script:
Sub CreatePDF_Selection1()
Dim rng1 As Range, rng2 As Range, rng3 As Range
Dim NewRng As Range
With ThisWorkbook.Sheets("Sheet1")
Set rng1 = .Range("A1:G9")
Set rng2 = .Range("A13:G14")
Set rng3 = .Range("A18:G37")
Set NewRng = .Range(rng1.Address & "," & rng2.Address & "," & rng3.Address)
Debug.Print NewRng.Address
Sheets("Sheet1").Activate
ActiveSheet.Range(NewRng.Address).Select
Sheets(Array("Sheet1")).Select
ThisWorkbook.Sheets(Array("Sheet1")).Select
Selection.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="U:\Sample Excel File Saved As PDF", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=True, _
From:=1, _
OpenAfterPublish:=True
End With
End Sub
Rather than select various ranges just hide the rows you don't want to print then print the entire range.
Option Explicit
Sub CreatePDF_Selection1()
Dim rng1 As Range
ThisWorkbook.Sheets("Sheet1").Activate
Set rng1 = Range("A1:G37")
Range("A10:A12").EntireRow.Hidden = True '*** Hide rows not to print ***
Range("A15:A17").EntireRow.Hidden = True
rng1.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="U:\Sample Excel File Saved As PDF", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=True, _
From:=1, _
OpenAfterPublish:=True
Rows("1:37").EntireRow.Hidden = False '*** Unhide hidden rows ***
End Sub 'CreatePDF_Selection1()
HTH
Edit: Attach test output.
I could not find a direct solution, so there is a work about here. A new worksheet will be added. The content will be copied there as a continuous range. The sheet will be exported as PDF, than the not needed sheet will be deleted.
Sub CreatePDF_Selection1()
Dim rng1 As Range, rng2 As Range, rng3 As Range
Dim NewRng As Range
Application.ScreenUpdating = False
With Sheet1
Set rng1 = .Range("A1:G9")
Set rng2 = .Range("A13:G14")
Set rng3 = .Range("A18:G37")
Set NewRng = Union(rng1, rng2, rng3)
End With
'Creating test values
rng1.Value = "Test 1"
rng2.Value = "Test 2"
rng3.Value = "Test 3"
NewRng.Copy
'adding a new sheet
Worksheets.Add after:=Sheet1
With ActiveSheet
.Paste
.ExportAsFixedFormat, _
Type:=xlTypePDF, _
Filename:="U:\Sample Excel File Saved As PDF", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=True, _
From:=1, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
.Delete 'delete the unwanted worksheet
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub
Export Non-Contiguous Range to PDF
This solution uses the Application.Union method to create the range to be exported. The range is then copied using the Range.Copy method to a newly added worksheet and exported from there. Then the newly added worksheet is deleted.
Option Explicit
Sub CreatePDF_Selection1()
Const FilePath As String = "U:\Sample Excel File Saved As PDF"
Const SheetName As String = "Sheet1"
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Copy Range.
With wb.Worksheets(SheetName)
Dim rng As Range
Set rng = Union(.Range("A1:G9"), .Range("A13:G14"), .Range("A18:G37"))
End With
' Copy Copy Range to new worksheet, export to PDF and delete new worksheet.
With Worksheets.Add
' This will copy values and formats.
rng.Copy .Range("A1")
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=FilePath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub

Replace Values in Range

I've tried to do this replacement in two different ways (first attempt commented below), but it ends up replacing everything on the sheet, instead:
Sub NoNullSaveCSV()
Dim WB As Workbook
Dim WS As Worksheet
Dim find1 As Variant
Dim rplc1 As Variant
Dim find2 As Variant
Dim rplc2 As Variant
Dim Rng As Range
Application.Workbooks.Add xlWBATWorksheet
Set WB = ActiveWorkbook
Set WS = ActiveSheet
With ThisWorkbook.Worksheets("PedidosTratados")
.Range("A3:DW1000").Copy
WS.Range("A1").PasteSpecial xlPasteValues
End With
WS.Range("A1").Value = "FilterCol"
WS.Columns.AutoFilter Field:=1, Criteria1:=""
WS.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
WS.AutoFilterMode = False
ReplaceCount = ReplaceCount + Application.WorksheetFunction.CountIf(WS.Cells, "*" & fnd1 & "*")
'+ Application.WorksheetFunction.CountIf(WS.Cells, "*" & fnd2 & "*")
fnd1 = "7.9000"
rplc1 = "7.900"
fnd2 = "9.9000"
rplc2 = "9.900"
With WS
.Range("AT2:DW1000").Replace fnd1, rplc1
.Range("AT2:DW1000").Replace fnd2, rplc2
'.Cells.Replace what:=fnd1, Replacement:=rplc1, _
'LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
'SearchFormat:=False, ReplaceFormat:=False
'.Cells.Replace what:=fnd2, Replacement:=rplc2, _
'LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
'SearchFormat:=False, ReplaceFormat:=False
End With
WB.SaveAs fileName:=ThisWorkbook.Path & "\Pedidos.csv", FileFormat:=xlCSV
WB.Close False
MsgBox "Após a pesquisa, foram feitas " & ReplaceCount & " substituições."
End Sub
Could you anyone tell me why this is not restraining replacement to the specified range?
Thank you!

How to export multiple sheets and save them in new created folder with same title as workbook

Tried to export worksheets to pdf with loop and save them in a newly created folder, the folder has the same name as the active workbook. Code worked in the previous file but now it won't loop anymore or save in the new folder. It creates the folder and it exports the active sheet to pdf nothing else.
When I run it I get runtime error 5 but only when I let it run as loop
I have already tried different filenames (active workbook.path & "\" &) and different ways to create a new folder (MkDir)
Sub ExportAsPDFAndSaveInNewFolder()
Dim wbA As Workbook
Dim wsA As Worksheet
Dim tdate As String
Dim fso As Object
Dim fldrName As String
Dim fldrpath As String
Dim myFile As String
Dim CF As Long, CV As Long, RF As Long, RV As Long
Dim Col As Long, Rw As Long
Dim path As String
Dim response As VbMsgBoxResult
' Set WS_Count equal to the number of worksheets in the active workbook.
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
tdate = "Dec"
'create new folder
Set fso = CreateObject("scripting.filesystemobject")
fldrName = wbA.name
fldrpath = ActiveWorkbook.path & "\" & Left(wbA.name, InStr(wbA.name, "."))
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
' Begin the loop.
For Each wsA In wbA.Sheets
wsA.Activate
'create a default name for saving file
myFile = "R Ch - S " & Year(Date) & " YTD " & tdate & " " & ActiveSheet.name & ".pdf"
if wsA.name <> "Top 25" and wsA.name <> "Top 10" then
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=**ActiveWorkbook.path & "\" & myFile, _**
(Filename:= fldrpath & myfile, _)
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With ActiveSheet
CF = .Cells.Find(What:="*", After:=Range("A1"),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Column
CV = .Cells.Find(What:="*", After:=Range("A1"),
LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Column
RF = .Cells.Find(What:="*", After:=Range("A1"),
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
RV = .Cells.Find(What:="*", After:=Range("A1"),
LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
Col = Application.WorksheetFunction.Max(CF, CV)
Rw = Application.WorksheetFunction.Max(RF, RV)
.PageSetup.Orientation = xlLandscape
.PageSetup.Zoom = False
.PageSetup.FitToPagesTall = False
.PageSetup.FitToPagesWide = 1
.PageSetup.PrintArea = "$A$1:" & Cells(Rw, Col).Address
End With
End if
Next wsA
response = MsgBox(prompt:="PDF's created and saved", Buttons:=vbOKOnly, Title:="Exported to PDF and saved in new folder")

Add exclusion to Excel macros

So I'm using this macro to save individual excel worksheets as their own PDF when run:
Sub SaveWorksheetsAsPDFs()
Dim sFile As String
Dim sPath As String
Dim wks As Worksheet
With ActiveWorkbook
sPath = .Path & "\"
For Each wks In .Worksheets
sFile = wks.Name & ".pdf"
wks.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sPath & sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next wks
End With
End Sub
I would just like to add to it to not start from a certain worksheet or to exclude certain worksheets. Any clue how?
You can use Select Case to specify sheetnames to ignore, as shown. Simply replace the "IgnoreSheet1", "IgnoreSheet2" with the actual sheet names you want skipped. It's just a comma delimited list, so add as many as you want.
Sub SaveWorksheetsAsPDFs()
Dim sFile As String
Dim sPath As String
Dim wks As Worksheet
With ActiveWorkbook
sPath = .Path & "\"
For Each wks In .Worksheets
Select Case wks.Name
Case "IgnoreSheet1", "IgnoreSheet2" 'Do nothing
Case Else
'Code here to run on the other sheets
sFile = wks.Name & ".pdf"
wks.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sPath & sFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Select
Next wks
End With
End Sub

Avoiding 'Save As' dialog box in Excel VBA script

I have cobbled together a VBA script that loops through a list of data, changing the value of a single cell on a summary page. That cell drives a number of formulas. After each iteration, the cell range of interest is saved off as a PDF.
I am looking to avoid having to manually hit enter every time the 'save as' dialog box is generated on each loop. Once I deploy this script, I could be looking at 1k+ iterations.
Sub AlterID()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
Set ws = Worksheets("Summary Data")
For Each c In Worksheets("Data").Range("A2:A11").Cells
Worksheets("Summary Data").Range("B1").Value = c.Value
strFile = ws.Range("D3").Value
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
ws.Range("D3:H9").Select
Selection.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
Next
End Sub
Sub AlterID()
Dim ws As Worksheet, c As Range
Dim strFile As String
Set ws = Worksheets("Summary Data")
For Each c In Worksheets("Data").Range("A2:A11").Cells
ws.Range("B1").Value = c.Value
strFile = ThisWorkbook.Path & "\" & ws.Range("D3").Value
ws.Range("D3:H9").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
End Sub
Have you tried turning off application alerts?
Application.DisplayAlerts = False 'before your code
Application.DisplayAlerts = True 'after your code
Edit 1
Here is a sub I use to save a file to a PDF
Sub SaveAsPDF()
Dim myValue As Variant
Dim mySheets As Variant
mySheets = Array("Report")
For Each sh In mySheets
Sheets(sh).PageSetup.Orientation = xlLandscape
Next
uid = InputBox("Enter your UID")
uid = StrConv(uid, vbProperCase)
Application.PrintCommunication = False
With Sheets("Report").PageSetup
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
Dim fName As String
fName = "HMB SOX report for week ending " & ActiveSheet.Range("H4").Text
Call selectPage("Report")
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
"C:\Users\" & uid & "\Desktop\" & fName, :=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, Publish:=False
End With
End Sub

Resources