Macro to save copies of 2 sheets with current with current filter and attached to email

[Padthelad]

Hi,

I am having trouble with a macro to export two sheets and attached to an email.

I have two tabs that I need to attach to an email to number of email address' (addresses' can be in cells A1,A2,A3 etc.). I can have the tab names to attach also in cells if needs be. Ideally I would the sheets to copy their current display settings (rows and columns are filtered).

I have the below code from a previous project that attaches a pdf copy and send to email address in a certain cell, but I am having trouble adapting to this task.

Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object

' Not sure for what the Title is
Title = Range("B10")

' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"

' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0


' Prepare e-mail with PDF attachment
With OutlApp.createitem(0)


    .Subject = CStr(Range("A8").Value)
Dim Mailadress As String
Mailadress = CStr(Range("B40").Value)
.to = Mailadress
.CC = ""
.Body = "Dear " & ActiveSheet.Range("B34 ").Value & " " & ActiveSheet.Range(" C34").Value & "," & vbLf & vbLf _
& "Please find attached document from *****." & vbLf & vbLf _
& "Should you have any questions or queries, do not hesitate to contact theoffice." & vbLf & vbLf _
& "Kind regards," & vbLf & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
.Attachments.Add "****Y:\TERMS AND CONDITIONS etc....****.pdf"
  


On Error Resume Next
.Display
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully Exported to Outlook. Remeber to press send!", vbInformation
End If
On Error GoTo 0

End With

Kill PdfFile

If IsCreated Then OutlApp.Quit

Set OutlApp = Nothing

End Sub

Any assistance anyone can provide is very much appreciated.

Thanks,

Pad

 

[davesexcel]

You can select the two sheets first then pdf them

    Sheets(Array("Sheet2", "Sheet1")).Select
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With

 

[Padthelad]

Hi Dave,

Thank you for your reply.

The sheet names vary, can I have the sheet names selected for export to be named within a cell reference. Also, I need to send the attachments as Excel format with the current display settings. This is what I am having trouble with. Exporting as excel, not pdf.

Many thanks,

Pad

 

[davesexcel]

Ah, you can copy the sheets into a new workbook, then save the new workbook.
Sheet 1 A1 & A2 have the sheet names in this example,

Dim sh1 As String
Dim sh2 As String

 sh1 = Sheets("Sheet1").Range("A1").Value
 sh2 = Sheets("Sheet1").Range("A2").Value

    Sheets(Array(sh1, sh2)).Copy
    'activeworkbook.SaveAs......

 

[Padthelad]

Can anyone help me with the below code?

I need the file to export as .xlsx and NOT a .pdf. Any ideas?

With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

Thanks,

 

[davesexcel]

I already told you, you don't export it, you create a copy of it and save it as a .xlsx

My previous post was code to create a copy of the two sheets into one workbook then use a saveas code to save it.