Ron,
Don't know wher to insert the signature bit to the mail merge you already
gave- can you help- code I'm using below
Thanks again,
David
Sub Send_Row_Or_Rows_1()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim StrBody As String
'With Selection.Font
'.Name = "Arial"
'.Size = 10
StrBody = "Please find below payments currently being processed on your
behalf." & "<br>" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br>" & _
"For all payment queries logon to
www.paymentconnexions.com or reply to this
email." & "<br>" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br>" & _
" " & "<br>" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br>" & _
" " & "<br>" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br><br>"
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A16:f" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
StrBody = "Please find below payments currently being processed on your
behalf." & "<br>" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br>" & _
"For all payment queries logon to
www.paymentconnexions.com or reply to this
email." & "<br>" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br>" & _
" " & "<br>" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br>" & _
" " & "<br>" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br><br>"
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0
If mailAddress <> "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = mailAddress
.Subject = Worksheets("Mailinfo").Range("e3")
'.Subject = "Test mail2"
.HTMLBody = StrBody & RangetoHTML(rng)
'.Signature = "Mercant Pmt"
.display 'Or use Send or Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
