Change macro to produce PDF's instead of workbooks

[austenr]

I would like to change this macro to make PDF's instead of workbooks

Sub WorkbookForEachSetMember() 'Creates a workbook and emails it to each SET member
     
     
    Dim wsMaster              As Worksheet
    Dim wbTemp                As Workbook
    Dim OutApp                As Object
    Dim OutMail               As Object
    Dim rngFilter             As Range 'filter range
    Dim rngUniques            As Range 'Unique Range
    Dim cell                  As Range
    Dim counter               As Integer
    Dim rngResults            As Range 'filter range
    Dim TempFilePath          As String
    Dim TempFileName          As String
    Dim vAddresses
    Dim FileExtStr            As String
    Dim FileFormatNum         As Long
     
     
    If Val(Application.Version) < 12 Then
         'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
         'You use Excel 2007-2013
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If
     
     
     ' change as necessary
    TempFilePath = "C:\testing\"
     
     
    vAddresses = Sheets("EmailAddresses").Range("SetMemberAddress").Resize(, 2).Value
     
     
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
     
     
    Set OutApp = CreateObject("Outlook.Application")
     
     
    Set wsMaster = ThisWorkbook.Worksheets("MasterSheet")
    With wsMaster
        Set rngFilter = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        Set rngResults = .Range("A1", .Range("H" & .Rows.Count).End(xlUp))
         
         
        rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set rngUniques = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
         
         
        .ShowAllData
         
         
    End With
     
     
    counter = 1
     
     
    For Each cell In rngUniques
        If vAddresses(counter, 1) Like "?*@?*.?*" And _
        LCase(vAddresses(counter, 2)) = "yes" Then
            Set wbTemp = Workbooks.Add(xlWBATWorksheet)
            wbTemp.ActiveSheet.Name = cell.Value
            rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
            rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbTemp.ActiveSheet.Range("A1")
             
             
            TempFileName = TempFilePath & cell.Value & FileExtStr
             
             
             
             
            Set OutMail = OutApp.CreateItem(0)
             
             
             
             
            With wbTemp
                .SaveAs TempFileName, FileFormat:=FileFormatNum
                 
                 
                On Error Resume Next
                With OutMail
                    .To = vAddresses(counter, 1)
                    .CC = ""
                    .BCC = ""
                    .Subject = "This is the Subject line"
                    .body = "Hi there"
                    .Attachments.Add TempFileName
                     'You can add other files also like this
                     '.Attachments.Add ("C:\test.txt")
                    .Send 'or use .Display
                End With
                On Error GoTo 0
                 
                 
                .Close savechanges:=False
                 
                 
            End With
             
             
            Set OutMail = Nothing
        End If
        counter = counter + 1
         
         
    Next cell
     
     
    rngFilter.Parent.AutoFilterMode = False
     
     
End Sub

[excelliot]

Change this 2 lines:

1st Line

TempFileName = TempFilePath & cell.Value & FileExtStr

Change to

TempFileName = TempFilePath & cell.Value & ".pdf"

Second line:

.SaveAs TempFileName, FileFormat:=FileFormatNum

to this line:

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

HTH//Cheers!!

[austenr]

Thanks for the help!! The following code with the changes errors off on:

.ShowAllData

Run time error, Method 'ShowAllData' of 'object _Worksheet' failed

Sub PDFForEachMember()
 
     
    Dim wsMaster              As Worksheet
    Dim wbTemp                As Workbook
    Dim OutApp                As Object
    Dim OutMail               As Object
    Dim rngFilter             As Range 'filter range
    Dim rngUniques            As Range 'Unique Range
    Dim cell                  As Range
    Dim counter               As Integer
    Dim rngResults            As Range 'filter range
    Dim TempFilePath          As String
    Dim TempFileName          As String
    Dim vAddresses
    Dim FileExtStr            As String
    Dim FileFormatNum         As Long
     
     
    If Val(Application.Version) < 12 Then
         'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
         'You use Excel 2007-2013
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If
     
     
     ' change as necessary
    TempFilePath = "C:\Users\arobinson1\Desktop\SRM Excel Data\"
     
     
    vAddresses = Sheets("Addresses").Range("SRMManagersAddress").Resize(, 2).Value
     
     
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
     
     
    Set OutApp = CreateObject("Outlook.Application")
     
     
    Set wsMaster = ThisWorkbook.Worksheets("Summary-Schedule")
    With wsMaster
        Set rngFilter = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        Set rngResults = .Range("A1", .Range("K" & .Rows.Count).End(xlUp))
         
         
        rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set rngUniques = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
         
         
        .ShowAllData
         
         
    End With
     
     
    counter = 1
     
     
    For Each cell In rngUniques
        If vAddresses(counter, 1) Like "?*@?*.?*" And _
        LCase(vAddresses(counter, 2)) = "yes" Then
            Set wbTemp = Workbooks.Add(xlWBATWorksheet)
            wbTemp.ActiveSheet.Name = cell.Value
            rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
            rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbTemp.ActiveSheet.Range("A1")
             
             
            'TempFileName = TempFilePath & cell.Value & FileExtStr
             TempFileName = TempFilePath & cell.Value & ".pdf"
             
             
             
            Set OutMail = OutApp.CreateItem(0)
             
             
             
             
            With wbTemp
                '.SaveAs TempFileName, FileFormat:=FileFormatNum
                 .ExportAsFixedFormat _
                  Type:=xlTypePDF, _
                  Filename:=TempFileName, _
                  Quality:=xlQualityStandard, _
                  IncludeDocProperties:=True, _
                  IgnorePrintAreas:=False, _
                  OpenAfterPublish:=False
                 
                 
                On Error Resume Next
                With OutMail
                    .To = vAddresses(counter, 1)
                    .CC = ""
                    .BCC = ""
                    .Subject = "Travel exceptions"
                    .body = "Here are the travel detail for your team who booked thier travel less than 14 days in advance"
                    .Attachments.Add TempFileName
                     'You can add other files also like this
                     '.Attachments.Add ("C:\test.txt")
                    .Send 'or use .Display
                End With
                On Error GoTo 0
                 
                 
                .Close savechanges:=False
                 
                 
            End With
             
             
            Set OutMail = Nothing
        End If
        counter = counter + 1
         
         
    Next cell
     
     
    rngFilter.Parent.AutoFilterMode = False
     
     
End Sub

[austenr]

Never mind I got it. Solved.