Use mail merge to send email the rows by filtering each unique column value

[PANIGGR]

I have excel file with more than 10K rows. I want to send multiple emails (more than 1000) by filtering all the rows for each column value (for e.g. Payment number in column E)
Is there aby VBA to do that, there is only one contact to send all the emails

 

[ranman256]

paste code into a module,

alter settgins:
vEmail = [to target email]
vSubj = your subject
vBody = your body statement

then run SendAllPayments

Public gcolPmts As Collection
Public gvPmt

'---------------------
Sub SendAllPayments()
'---------------------
Dim iRows As Long, iFldNum As Long, iResultOFF As Long
Dim vTxt, vEmail, vBody, vPmt, vSubj, vFile
Dim i As Integer

vEmail = "w.e.coyote@acme.com"

  'load payment vals
LoadPmtVals

Range("A1").Select

For i = 1 To gcolPmts.Count
    gvPmt = gcolPmts(i)
    ActiveSheet.Range("A1").AutoFilter Field:=5, Criteria1:=gvPmt              'filter results
    
      'save payment data
    vFile = SaveFoundData(gvPmt)
    
       'send email
    vSubj = "subject: " & gvPmt
    vBody = "This is the body of the email"

    Send1Email vEmail, vSubj, vBody, vFile
       'remove filter
    ActiveSheet.Range("A1").AutoFilter
Next
Set gcolPmts = Nothing
End Sub


Private Sub LoadPmtVals()
On Error Resume Next

Set gcolPmts = New Collection
Range("E2").Select
While ActiveCell.Value <> ""
   gvPmt = ActiveCell.Value
   gcolPmts.Add gvPmt, gvPmt
   
   ActiveCell.Offset(1, 0).Select     'next row
Wend
End Sub


'---------------------
Private Function SaveFoundData(ByVal pvPmtNum)
'---------------------
Dim vFile, vDir

vDir = getMyDocs()
vFile = vDir & pvPmtNum & ".xlsx"

Range("A1").Select
ActiveSheet.UsedRange.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    KillFile vFile
    ActiveWorkbook.SaveAs Filename:=vFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    SaveFoundData = vFile   'return the file to email
End Function



Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem

On Error GoTo ErrMail

'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library

Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this

Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
    
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
    
    .Display True   'show user but dont send yet
    '.Send          'send now
End With

Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
'DoCmd.OutputTo acOutputReport, "rMyReport", acFormatPDF, vFile

End Function

Private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If

If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If

'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function

Public Function getMyDocs()
getMyDocs = Environ$("USERPROFILE") & "\Documents\"
End Function


Public Sub KillFile(ByVal pvFile)
Dim fso
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
'FileReadOnly pvFile, False
fso.DeleteFile pvFile
Set fso = Nothing
End Sub

 

[PANIGGR]

replying lately, thanks a lot for this