How to Insert another loop for inputting multiple receiver name in an Email based on criteria

[AmirFirdaus9509]

Hi There ,
How to dynamically insert receiver name based on array that follow a criteria in the excel file.
For example , there are 3 different country US , JP and UK. The macro is able to create 3 different email draft and insert the table based on criteria of each country. It will create UK Email and only put table that have UK in Column A.
How to initiate another loop that insert receiver name only that is the same row as UK and will also loop for US and JP ?

Sample table containing data.

Here is the code that i working on with more country data in it

Sub test()
     
    Dim my_array() As String
    Dim i As Integer
    Dim NumRows As Integer
    
    ReDim my_array(37)
    my_array(0) = "AU"
    my_array(1) = "BD"
    my_array(2) = "BN"
    my_array(3) = "CN"
    my_array(4) = "FJ"
    my_array(5) = "HK"
    my_array(6) = "ID"
    my_array(7) = "IN"
    my_array(8) = "JP"
    my_array(9) = "KH"
    my_array(10) = "KR"
    my_array(11) = "LA"
    my_array(12) = "LK"
    my_array(13) = "MM"
    my_array(14) = "MN"
    my_array(15) = "M0"
    my_array(16) = "MV"
    my_array(17) = "MY"
    my_array(18) = "NP"
    my_array(19) = "NZ"
    my_array(20) = "PH"
    my_array(21) = "PK"
    my_array(22) = "SG"
    my_array(23) = "TH"
    my_array(24) = "TW"
    my_array(25) = "VN"
    my_array(26) = "TO"
    my_array(27) = "CK"
    my_array(28) = "KI"
    my_array(29) = "NR"
    my_array(30) = "NC"
    my_array(31) = "NU"
    my_array(32) = "WS"
    my_array(33) = "SB"
    my_array(34) = "PF"
    my_array(35) = "TO"
    my_array(36) = "TV"
    my_array(37) = "VU"
    


    For i = LBound(my_array) To UBound(my_array)
        ActiveSheet.UsedRange.AutoFilter Field:=7, Criteria1:=my_array(i)
        
 
  Set URng = ActiveSheet.UsedRange
      NumRows = URng.Resize(, 1).SpecialCells(xlCellTypeVisible).Count
          
      If NumRows > 1 Then
    

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
   
    Set rng = Nothing
    On Error Resume Next
    
    Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
   
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
    
        SName = " "
               
        .To = ""
        .CC = ""
        .BCC = ""
        .subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        '.Send
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing


 End If
     On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
        

    Next i
     
End Sub

Thanks for any assistance in advance

 

[portews]

Try this. I would put this just before

Set OutApp = CreateObject("Outlook.Application")

Dim j as Long
Dim recievers as String
With Sheets("Emails") 'change to whatever sheet you have the email addresses stored in.
   'find the last row in A with something in it
   lastrow = .Range("A" & Rows.Count).End(xlUp).Row
   'loop through the cells 
   For j = 2 To lastrow
        'if the country matches, add the email address to a string variable
        If .Cells(j, 1) = my_array(i) Then recievers = recievers & .Cells(j, 2) & ", "
   Next j
End With

and, in place of

.To = ""

put

.To = recievers

 

[AmirFirdaus9509]

Try this. I would put this just before

Set OutApp = CreateObject("Outlook.Application")

Dim j as Long
Dim recievers as String
With Sheets("Emails") 'change to whatever sheet you have the email addresses stored in.
   'find the last row in A with something in it
   lastrow = .Range("A" & Rows.Count).End(xlUp).Row
   'loop through the cells
   For j = 2 To lastrow
        'if the country matches, add the email address to a string variable
        If .Cells(j, 1) = my_array(i) Then recievers = recievers & .Cells(j, 2) & ", "
   Next j
End With

and, in place of

.To = ""

put

.To = recievers

Hi There ,
apologize for a late reply as i was not available to access internet for some time

Thanks for assisting me on this , I have encountered issue as the receipient name is duplicated from other countries into the email.
How to sort so it will only take under specific country for reciepient instead of all?
Thank you

 

[portews]

It should only give you the emails for the matching country. Can you post your code to see how you implemented what I had sent?