On Excel with VBA how to send an mail to one email with excel information in it

Question

I would like that from this code a code that for each different emails (column 12 of my Excel table) it recovers the values of the columns 1, 2 and 3 and puts them in the body of the mails with for the column 1 the partners the column 2 RAA and the 3 ID. It is necessary to take into account that if the mails is 2 times in the Excel it makes a list for the partners the RAA and ID.

For the moment I get something like that:

Hello, 
we are doing some users (ulogin) cleaning for partners. 
We have identified the following users for which you are the owner : 
Partner name: XXX | RAA: 001 | ID: 002 
Please gave us some feedback on those users which did not connect in 
more than 20 mounths or never sometimes. 
If we get no feed back from you, we will initiate removal of those users. 
Best regards,  

This is correct if the owner have only one partner name but in my code I get this even if he get 2 Partner name 2 RAA and 2 ID or more. and I want get something like this when in my excel I get 2 time the same email (owner):

Hello, 
we are doing some users (ulogin) cleaning for partners. 
We have identified the following users for which you are the owner : 
Partner name: XXX, AAA | RAA: 001,012 | ID: 002,341
Please gave us some feedback on those users which did not connect in 
more than 20 mounths or never sometimes. 
If we get no feed back from you, we will initiate removal of those users. 
Best regards,  

I hope I am clear thank you for helping me

Private Sub CommandButton1_Click()
  Dim sh As Worksheet, lastRQ As Long, arr, arrUs, i As Long, j As Long
  Dim mail As Object, strUsers As String, dict As Object
  Set sh = ActiveSheet
  lastRQ = sh.Range("AA" & sh.Rows.Count).End(xlUp).Row 'last row on AA:AA
  arr = sh.Range("A2:AA" & lastRQ).Value 'place the range in an array for faster processing
  'Place the necessary data in the dictionary:
  Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
  For i = 1 To UBound(arr)
    If arr(i, 27) = "to do" Then
      If Not dict.Exists(arr(i, 9)) Then
        dict.Add arr(i, 9), arr(i, 2) & " / " & arr(i, 3) & " / " & arr(i, 1) & " / " & arr(i, 4)
      Else
        dict(arr(i, 9)) = dict(arr(i, 9)) & " / " & arr(i, 1) & " / " & arr(i, 2) & " / " & arr(i, 3) & " / " & arr(i, 4)
      End If
    End If
  Next i
  Set mail = CreateObject("Outlook.Application") 'create an outlook object
  'extract the necessary data:
  For i = 0 To dict.Count - 1
    arr = Split(dict.Items()(i), " / ") 'split the item by " / " to extract values
    arrUs = Split(arr(3), " / ")

    If UBound(arrUs) > 0 Then
      'get the RAA, ID and partner name for each user
      strUsers = ""
      For j = 0 To UBound(arrUs)
        strUsers = strUsers & "Partner name: " & arrUs(j) & " | RAA: " & arr(0) & " | ID: " & arr(2) & Chr(13) & Chr(10)
      Next j
      strUsers = strUsers & "Please gave us some feedback on those users which did not connect in more than 20 mounths or never sometimes." & Chr(13) & Chr(10) & "If we get no feed back from you, we will initiate removal of those users. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Best regards," & Chr(10) & "xxx"
    Else
      strUsers = "Partner name: " & arr(1) & " | RAA: " & arr(0) & " | ID: " & arr(2) & Chr(13) & Chr(10) & "Please gave us some feedback on those users which did not connect in more than 20 mounths or never sometimes." & Chr(13) & Chr(10) & "If we get no feed back from you, we will initiate removal of those users. " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Best regards," & Chr(10) & "xxx"
    End If
    With mail.CreateItem(olMailItem)
      .Subject = "Ulogin cleaning - Never connected or not since more than 20+ months"
      .To = dict.Keys()(i)
      .CC = "[email protected]"
      .Body = "Hello," & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "we are doing some users (ulogin) cleaning for partners." & Chr(13) & Chr(10) & "We have identified the following users for which you are the owner : " & strUsers
      .Display ' See the New mail in Outlook and check its contents
    End With
  Next i
End Sub

Answer 1

Thank you I work on in and I find how to do what I wanted !

Private Sub CommandButton1_Click()
  Dim sh As Worksheet, lastRQ As Long, arr, i As Long, j As Long
  Dim mail As Object, strUsers As String, dict As Object
  Set sh = ActiveSheet
  lastRQ = sh.Range("AA" & sh.Rows.Count).End(xlUp).Row 'last row on AA:AA
  arr = sh.Range("A2:AA" & lastRQ).Value 'place the range in an array for faster processing
  'Place the necessary data in the dictionary:
  Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
  For i = 1 To UBound(arr)
    If arr(i, 27) = "to do" Then
      If Not dict.Exists(arr(i, 12)) Then
        dict.Add arr(i, 12), "Partenaire: " & arr(i, 3) & " | RAA: " & arr(i, 2) & " | ID: " & arr(i, 1)
      Else
        dict(arr(i, 12)) = dict(arr(i, 12)) & " / " & "Partenaire: " & arr(i, 3) & " | RAA: " & arr(i, 2) & " | ID: " & arr(i, 1)
      End If
    End If
  Next i
  Set mail = CreateObject("Outlook.Application") 'create an outlook object
  'extract the necessary data:
  For i = 0 To dict.Count - 1
    strUsers = dict.Items()(i)
    With mail.CreateItem(olMailItem)
    .Subject = "Ulogin cleaning - Never connected or not since more than 20+ months"
    .To = dict.Keys()(i)
    .CC = "[email protected]"
    .Body = "Hello," & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "we are doing some users (ulogin) cleaning for partners." & Chr(13) & Chr(10) & "We have identified the following users for which you are the owner : " & strUsers
    .Display ' See the New mail in Outlook and check its contents
    End With
  Next i
End Sub