Saving Excel Selection as A PDF document

[PaulM]

Hello All!

I've been trying to figure out how to save a range that is selected by the user (while ignoring all hidden rows and columns) as a PDF document with a similar name to the original document. Ideally, a button would be made containing this code at the top of the spreadsheet in a frozen pane. Don't worry about the file path

So far what I have in terms of coding is this:

Sub GmailTest()


Dim Rng As Range
Dim wb As Workbook
Dim Tempwb As Workbook
Dim FileName As String
Dim TestFileName As String


Set Rng = Selection.SpecialCells(xlCellTypeVisible)
Set wb = ActiveWorkbook
Set Tempwb = Workbooks.Add
TestFileName = "Macintosh HD:Users:Crystal:Desktop:Test.xlsx"


With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With


If Rng Is Nothing Then
    MsgBox "Please select a range and try again."
    Exit Sub
End If


Rng.COPY
Windows(Tempwb).Activate
With ActiveSheet
    .PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteFormats
End With


ActiveWorkbook.SaveAs TestFileName, xlPDF


With Application
    .ScreenUpdating = True
    .EnableEvents = True


End Sub

The problem I'm running into right now is that when I run it,

Windows(Tempwb).Activate

that doesn't work. I know that there's an easier way to do this out there, I just don't know how to though.

I am using excel version 2011 (Mac version) and if anyone can help me, I would greatly appreciate it!

[PaulM]

Update!

I got it to work, however, now when I save the selection as a pdf, the name of the pdf has an added "(Sheet 1)" on it. I'm sure it's coming from when the workbook gets created. Does anyone know how to make that not happen?

Here is the updated code:

Sub GmailTest()


Dim Rng As Range
Dim wb As Workbook
Dim Tempwb As Workbook
Dim FileName As String
Dim TestFileName As String


TestFileName = "Macintosh HD:Users:Crystal:Desktop:Test2.pdf"
Set Rng = Selection.SpecialCells(xlCellTypeVisible)
Set wb = ActiveWorkbook


With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With


If Rng Is Nothing Then
    MsgBox "Please select a range and try again."
    Exit Sub
End If


Rng.COPY


Workbooks.Add


With ActiveWorkbook
    Cells(1).PasteSpecial Paste:=xlPasteValues
    Cells(1).PasteSpecial Paste:=xlPasteFormats
End With


ActiveWorkbook.SaveAs TestFileName, xlPDF


With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With


End Sub

[Kenneth Hobs]

You could use a worksheet as a scratch sheet or create one and delete it as I did.

Sub ken()  
 Dim Rng As Range, thisSheet As Worksheet, ws As Worksheet, FileName As String
   
  FileName = ActiveWorkbook.Path & "\ken.pdf" '"Macintosh HD:Users:Crystal:Desktop:Test2.pdf"
  
  Set Rng = Selection.SpecialCells(xlCellTypeVisible)
  Set thisSheet = ActiveSheet
  Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
   
  If Rng Is Nothing Then
      MsgBox "Please select a range and try again."
      Exit Sub
  End If
 
  Rng.Copy Range("A1")
  PublishToPDF ActiveSheet.UsedRange, ActiveWorkbook.Path & "\ken.pdf"
  thisSheet.Select
  
  Application.DisplayAlerts = False
  ws.Delete
  Application.DisplayAlerts = True
  
  Shell "cmd /c " & """" & FileName & """", vbNormalFocus
End Sub


Sub PublishToPDF(o As Object, Optional fn As String = "")
  Dim rc As Variant
  
  If fn = "" Then
    rc = Application.GetSaveAsFilename(fn, "PDF (*.pdf), *.pdf", 1, "Publish to PDF")
Else:     rc = fn
    End If
  If rc = "" Or rc = False Then Exit Sub
  
  o.ExportAsFixedFormat Type:=xlTypePDF, FileName:=rc _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
  :=False, OpenAfterPublish:=False
End Sub

[PaulM]

Ken,

Thank you for your response!

I was wondering why you separated it out into 2 different subs. Is there some reason you needed that?

I was able to use some things from your answer and mold it to what I think will work. I combined everything into one sub and changed the name of the pdf to more accurately reflect what I'm looking for.

Here's the code:

Sub GmailTest()


Dim Rng As Range
Dim Tempws As Worksheet
Dim FileName As String


Set Rng = Selection.SpecialCells(xlCellTypeVisible)
FileName = ActiveWorkbook.Path & ":" & Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".", 1) - 1) _
                        & " (" & Format(Now, "mmm d") & ").pdf"
Set Tempws = Worksheets.Add(after:=Worksheets(Worksheets.Count))


If Rng Is Nothing Then
    MsgBox "Please select a range and try again."
    Exit Sub
End If


Rng.COPY


With Tempws
    Cells(1).PasteSpecial Paste:=xlPasteValues
    Cells(1).PasteSpecial Paste:=xlPasteFormats
End With


Tempws.ExportAsFixedFormat xlTypePDF, FileName, xlQualityStandard


Application.DisplayAlerts = False
Tempws.Delete
Application.DisplayAlerts = True




End Sub

Now I know that this wan't what I was initially after, but ultimately, I'm looking to e-mail this pdf out in a gmail email. I'm going to look through the web to figure this one out, but if you know anything that might help, that would be wonderful!

[Kenneth Hobs]

Since I reuse some routines so often, I put them into well, modular routines.

Ron de Bruin may have moved some of his links.

For Gmail, I would use CDO.

Sub Test_Gmail()  Gmail "ken@gmail.com", "ken", "Hello World!", _
    "This is a test using CDO to send Gmail with an attachement.", _
    "ken@odot.org", "sent@from.com", _
    "x:\test\test.xlsm"
End Sub


' http://www.blueclaw-db.com/access_email_gmail.htm
' http://msdn.microsoft.com/en-us/library/ms872547%28EXCHG.65%29.aspx
' Add CDO reference for early binding method
'   Tools > References > Microsoft CDO for Windows 2000 Library
'     c:\windows\system32\cdosys.dll
' http://www.rondebruin.nl/cdo.htm  'Other cdo tips for cdo to Outlook from Excel
' http://www.rondebruin.nl/win/s1/cdo.htm
Function Gmail(sendUsername As String, sendPassword As String, subject As String, _
  textBody As String, sendTo As String, sendFrom As String, _
  Optional sAttachment As String = "")
  
  'Dim cdomsg as Object 'late binding method
  ' Set cdomsg = CreateObject("CDO.message")  'late binding method
  Dim cdomsg As New CDO.Message  'early binding method
  With cdomsg.Configuration.Fields
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sendUsername
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sendPassword
    .Update
  End With
  ' build email parts
  With cdomsg
    .To = sendTo
    .From = sendFrom
    .subject = subject
    .textBody = textBody
    If Dir(sAttachment) = "" Then sAttachment = ""
    If sAttachment <> "" Then .AddAttachment (sAttachment)
    .Send
  End With
  Set cdomsg = Nothing
End Function

[PaulM]

Thank you again Ken!

I got everything to work, but then after updating a few excel pages with buttons to make this happen, something changed and now it doesn't work anymore!

I'm getting the error:

Runtime error '1004'
Method 'ExportAsFixedFormat' of object '_Worksheet' failed

Obviously it has to do with exporting the worksheet as a PDF, but I have no idea how to fix it.

Here the most updated code:

Sub Email_as_PDF()
'
' Email_as_PDF Macro
' E-mails user's chosen selection as a PDF document  Shortcut: Option+Cmd+p
'
' Keyboard Shortcut: Option+Cmd+p
'
Dim Rng As Range
Dim ws As Worksheet
Dim Tempws As Worksheet
Dim FileName As String


Application.ScreenUpdating = False


Set ws = ActiveSheet
Set Rng = Selection.SpecialCells(xlCellTypeVisible)
FileName = ActiveWorkbook.Path & ":" & Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".", 1) - 1) _
                        & " (" & Format(Now, "mmm d yyyy") & ").pdf"
Set Tempws = Worksheets.Add(after:=Worksheets(Worksheets.Count))


If Rng Is Nothing Then
    MsgBox "Please select a range and try again."
    Exit Sub
End If


Rng.Copy


With Tempws
    Cells(1).PasteSpecial Paste:=xlPasteColumnWidths
    Cells(1).PasteSpecial Paste:=xlPasteValues
    Cells(1).PasteSpecial Paste:=xlPasteFormats
End With


Tempws.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    FileName:=FileName, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True


Application.DisplayAlerts = False
Tempws.Delete
Application.DisplayAlerts = True


ws.Select

'<insert function that e-mails a file with the name of FileName>