VBA to save only Visible cells in PDF

[dmbpt]

Hi guys,

I have the following code (below) which saves my active worksheet as a PDF. It works fine, however, my sheet has approximately 8000 rows, with an autofilter and the information i see on the screen is not reflected on the PDF (i.e: the info I have is 300 rows, but my PDF shows the full 215 page report - mostly consisting of blank pages...)

How can i create a PDF displaying ONLY visible rows/cells?

Thanks

This is the code:

Sub PDFActiveSheet()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
On Error GoTo errHandler


Set ws = ActiveSheet


'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _
& "_" _
& Sheet18.Cells(14, 17) _
& ".pdf"
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.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True


MsgBox "PDF created"
End If


exitHandler:
Exit Sub
errHandler:
MsgBox "PDF not created"
Resume exitHandler
End Sub

 

[Kenneth Hobson]

Click the # icon to insert code tags. Paste code between them.

Add a scratch worksheet in the current workbook or a scratch workbook. Example of former:

Sub Main()
  Dim MyFile As String, ws As Worksheet, wsScratch As Worksheet
  
  MyFile = Environ("temp") & "\ken.pdf"
  Set ws = ActiveSheet
  
  Set wsScratch = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  
  ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsScratch.Range("A1")

  wsScratch.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=MyFile, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
  
  Application.DisplayAlerts = False
  wsScratch.Delete
  Application.DisplayAlerts = True
End Sub

 

[dmbpt]

Hi Kenneth,

Thank you for your reply. It doesn't seem to be working. i think its because of the range i put in "ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsScratch.Range("C17:BN7954")".

I used your code to complete mine:

Sub PDFActiveSheet()
Dim ws As Worksheet, wsScratch As Worksheet
Dim strPath As String
Dim MyFile As Variant
Dim strFile As String
On Error GoTo errHandler




Set ws = ActiveSheet


'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(ws.Name, " ", ""), ".", "_") _
& "_" _
& Sheet18.Cells(14, 17) _
& ".pdf"
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

Set wsScratch = Worksheets.Add(After:=Worksheets(Worksheets.Count))

ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsScratch.Range("C17:BN7954")


wsScratch.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=MyFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True

Application.DisplayAlerts = False
wsScratch.Delete
Application.DisplayAlerts = True


MsgBox "PDF criado com sucesso!"
End If


exitHandler:
Exit Sub
errHandler:
MsgBox "Não foi possível criar o PDF"
Resume exitHandler
End Sub

Click the # icon to insert code tags. Paste code between them.

Add a scratch worksheet in the current workbook or a scratch workbook. Example of former:

Sub Main()
  Dim MyFile As String, ws As Worksheet, wsScratch As Worksheet
  
  MyFile = Environ("temp") & "\ken.pdf"
  Set ws = ActiveSheet
  
  Set wsScratch = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  
  ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsScratch.Range("A1")

  wsScratch.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=MyFile, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
  
  Application.DisplayAlerts = False
  wsScratch.Delete
  Application.DisplayAlerts = True
End Sub

 

[Kenneth Hobson]

Again, please paste code between code tags. There is no need to quote all code or a reply. Just say see post #2 if needed.

Right. Ok, let's think about what you told Excel to do with this line:

ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsScratch.Range("C17:BN7954")

You are telling Excel to paste copied columns and rows however big or small, to a set column and row size. Excel does not like that. While one can determine the number of columns and rows in such cases, it is easier to just paste to the top left cell. In your case, I guess it would be:

ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy wsScratch.Range("C17")