austenr
07-31-2015, 11:06 AM
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
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