How to send a Group Email based on cell content by using Macro

[AmirFirdaus9509]

Hi All ,
I would like to request an advice how to send multiple group email based on a cell content. Currently i have a table that contain , name , country , email , cc , subject.
The current existing macro that i have is able to send an email individually within the table.
I am testing out and currently at a dead end on how to send an email by group based on a cell country. In context , if there was 10 row of data and contain country such as US , UK and JP. There would be 3 different email generate within it . Here is an example of image for more clarity.

Sample of Table

Sample Email generated once run.

Here is my code that i am working on as reference.

Sub send_mass_email()
    Dim i As Integer, cel As Range
    Dim name As String, email As String, body As String, subject As String, copy As String, place As String, business As String
    Dim OutApp As Object, OutMail As Object
    body = ActiveSheet.TextBoxes("TextBox 1").Text
    Set OutApp = CreateObject("Outlook.Application")
    For Each cel In Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        name = Split(cel, " ")(0) 'extract first name
        email = cel.Offset(, 1).Value
        subject = cel.Offset(, 2).Value
        copy = cel.Offset(, 3).Value
        Company = cel.Offset(, 4).Value
        Origin = cel.Offset(, 5).Value
        Paragraph = cel.Offset(, 7).Value
        'replace place holders
        body = Replace(body, "C1", name)
        body = Replace(body, "C5", Company)
        body = Replace(body, "C6", Origin)
        body = Replace(body, "C7", Paragraph)
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = email
            .CC = copy
            .subject = subject
            .body = body
            '.HTMLBody = RangetoHTML("Q2:T3")
            '.Attachments.Add ("") 'You can add files here
            .display
            '.Send
        End With
    Next cel
    MsgBox "Email(s) Created!"
End Sub

Thank you very much for any assistance

 

[OaklandJim]

This should get you started.

Sub SendCountryEmail()

    Dim sMessage As String
    
'   array for country codes
    Dim asCountryCodes() As String
    
'   var used to get each country code from array
    Dim sCountryCode As String
   
'   Used to loop countries
    Dim iCountry As Integer
        
'   Size array fro three country codes.
    ReDim asCountryCodes(3)
    
'   Message in body
    sMessage = "Message line 1" & Chr(10) & "Message line 2"
    
'   put country codes into the array
    asCountryCodes(1) = "JP"
    asCountryCodes(2) = "US"
    asCountryCodes(3) = "UK"
    
'   Process each country (code)
    For iCountry = 1 To UBound(asCountryCodes)
        sCountryCode = asCountryCodes(iCountry)
        Call SendEmail(sCountryCode, sMessage)
    Next

End Sub


Sub SendEmail(psCountryCode As String, psMessage As String)

'   Setting up the Excel variables (Outlook objects).
    Dim olApp As Object      'Outlook app object
    Dim olMailItm As Object  'Email object
    
'   Counter for rows processed for looping
    Dim iRowsProcessed As Integer
    
    Dim sRecipient As String
    
    Dim sRecipientList As String
    
    Dim sSubject As String
    
    Dim iRecipient As Long
    
    Dim iRecipientsFound As Long
   
'   "Header" cells for ranges
    Dim rCountryHeader As Range
    Dim rEmailHeader As Range
    Dim rSubjectHeader As Range
   
'   Create the Outlook application and the empty email.
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItm = olApp.CreateItem(0)
   
'   Set range objects
    With Worksheets("Sheet1")
        Set rCountryHeader = .Range("A1")
        Set rEmailHeader = .Range("B1")
        Set rSubjectHeader = .Range("D1")
    End With
    
    sRecipientList = ""
    
    iRecipient = 0
   
    sRecipientList = ""
    
    For iRowsProcessed = 1 To WorksheetFunction.CountA(Columns(1)) - 1
    
        iRecipient = iRecipient + 1
    
        If rCountryHeader.Offset(iRowsProcessed) = psCountryCode _
         Then
         
            iRecipientsFound = iRecipientsFound + 1
            
            If iRecipientsFound = 1 _
             Then sSubject = rSubjectHeader.Offset(iRowsProcessed)
            
            sRecipient = rEmailHeader.Offset(iRowsProcessed).Value
            
            If iRecipientsFound = 1 _
             Then
                sRecipientList = sRecipient

            Else
                sRecipientList = sRecipientList & ";" & sRecipient
                
            End If
        End If
                 
     Next iRowsProcessed
       
Debug.Print "sSubject = " & sSubject
Debug.Print "sRecipientList = " & sRecipientList

'   Using the email object, add multiple recipients, message and subject.
    With olMailItm
    
'       Add BCC, Subject line, and message
       .BCC = sRecipientList
       .Subject = sSubject
       .Body = psMessage
       '.Send
   
   End With
   
   'Clean up the Outlook application.
   Set olMailItm = Nothing
   Set olApp = Nothing

End Sub

 

[AmirFirdaus9509]

This should get you started.

Sub SendCountryEmail()

    Dim sMessage As String
   
'   array for country codes
    Dim asCountryCodes() As String
   
'   var used to get each country code from array
    Dim sCountryCode As String
  
'   Used to loop countries
    Dim iCountry As Integer
       
'   Size array fro three country codes.
    ReDim asCountryCodes(3)
   
'   Message in body
    sMessage = "Message line 1" & Chr(10) & "Message line 2"
   
'   put country codes into the array
    asCountryCodes(1) = "JP"
    asCountryCodes(2) = "US"
    asCountryCodes(3) = "UK"
   
'   Process each country (code)
    For iCountry = 1 To UBound(asCountryCodes)
        sCountryCode = asCountryCodes(iCountry)
        Call SendEmail(sCountryCode, sMessage)
    Next

End Sub


Sub SendEmail(psCountryCode As String, psMessage As String)

'   Setting up the Excel variables (Outlook objects).
    Dim olApp As Object      'Outlook app object
    Dim olMailItm As Object  'Email object
   
'   Counter for rows processed for looping
    Dim iRowsProcessed As Integer
   
    Dim sRecipient As String
   
    Dim sRecipientList As String
   
    Dim sSubject As String
   
    Dim iRecipient As Long
   
    Dim iRecipientsFound As Long
  
'   "Header" cells for ranges
    Dim rCountryHeader As Range
    Dim rEmailHeader As Range
    Dim rSubjectHeader As Range
  
'   Create the Outlook application and the empty email.
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItm = olApp.CreateItem(0)
  
'   Set range objects
    With Worksheets("Sheet1")
        Set rCountryHeader = .Range("A1")
        Set rEmailHeader = .Range("B1")
        Set rSubjectHeader = .Range("D1")
    End With
   
    sRecipientList = ""
   
    iRecipient = 0
  
    sRecipientList = ""
   
    For iRowsProcessed = 1 To WorksheetFunction.CountA(Columns(1)) - 1
   
        iRecipient = iRecipient + 1
   
        If rCountryHeader.Offset(iRowsProcessed) = psCountryCode _
         Then
        
            iRecipientsFound = iRecipientsFound + 1
           
            If iRecipientsFound = 1 _
             Then sSubject = rSubjectHeader.Offset(iRowsProcessed)
           
            sRecipient = rEmailHeader.Offset(iRowsProcessed).Value
           
            If iRecipientsFound = 1 _
             Then
                sRecipientList = sRecipient

            Else
                sRecipientList = sRecipientList & ";" & sRecipient
               
            End If
        End If
                
     Next iRowsProcessed
      
Debug.Print "sSubject = " & sSubject
Debug.Print "sRecipientList = " & sRecipientList

'   Using the email object, add multiple recipients, message and subject.
    With olMailItm
   
'       Add BCC, Subject line, and message
       .BCC = sRecipientList
       .Subject = sSubject
       .Body = psMessage
       '.Send
  
   End With
  
   'Clean up the Outlook application.
   Set olMailItm = Nothing
   Set olApp = Nothing

End Sub

Hi There Jim ,
Thank you very much for the help.
This really help me what to look for!