Send an email with content from different rows

I have the below VBA code to send emails with attachment.

What this code does: Generates and sends emails with attachment, whose information is from separate rows in the Excel table.
What I want the code to do: Recognise transactions from the same account to include in one email. This information is in column B of the table.
How I want this code to be improved:
1. I want to check all cell values in column B to see if there are any transactions coming from the same account to include them in the same email instead of sending them separately.
2. I think the changes must be made to these parts of the code:
  - If there is more than one transaction in one email, the transaction summary part should repeat correspondingly.
  - If there is more than one transaction in one email, there should also be more than one attachment. The attachment part would need to be modified accordingly.

Some important columns:

B: Account number
O: Attachment file name

The full code:

Sub SendEmail_Dispute()
' email processing

For i = 2 To Sheet2.Range("A" & Rows.Count).End(xlUp).Row
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application

Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)

EmailItem.To = "[email protected]"
EmailItem.Subject = "#" & Sheet2.Range("B" & i).Value & " - " & Sheet2.Range("M" & i).Value & ": " & Sheet2.Range("S" & i).Value

'[Transaction Summary Part] (starting at "------Transaction Summary-------")

EmailItem.HTMLBody = "Dear our valued customer, " & "<br>" & "<br>" & "We have registered a suspicious transaction from your account with number: " & "<b>" & Sheet2.Range("G" & i).Value & " - " & Sheet2.Range("H" & i).Value & "</b>" & ". The information is as follows: " & "<br>" & "<br>" & _
"------Transaction Summary-------" & "<br>" & "<br>" & _
"<table>" & _
"<table border='1' cellspacing='0' cellpadding=4'>" & _
"<tr><td><b> Transaction ID: </b></td><td>" & Sheet2.Range("C" & i).Value & "</td><td>" & Sheet2.Range("M" & i).Value & "</td></tr>" & _
"<tr><td><b> Transaction Amount: </b></td><td>" & Sheet2.Range("K" & i).Value & "</td><td>" & Sheet2.Range("T" & i).Value & " " & Sheet2.Range("W" & i).Value & "</td></tr>" & _
"<tr><td><b> Transaction Date: </b></td><td>" & Sheet2.Range("J" & i).Value & "</td><td>" & Sheet2.Range("U" & i).Value & "</td></tr>" & _
"</table>" & _
"<br>" & "<br>" & _
"Thank you" & "<br>" & "Best regards,"

'[Attachment Part]

'Source = ThisWorkbook.FullName
'---------Attachment
Dim fso As Scripting.FileSystemObject
Set fso = New FileSystemObject
Dim file As Scripting.file
Dim folder As Scripting.folder
Set folder = fso.GetFolder("C:\Users\main\Desktop\sus trx")
'Source = "C:\test"
For Each file In folder.Files
    If Sheet2.Range("O" & i).Value = fso.GetBaseName(file.Name) Then

        EmailItem.Attachments.Add file.Path
        Exit For
        
    End If
Next file

EmailItem.Send
Next i
End Sub

Solution

try

Sub SendEmails()
    
    Dim Applications As Object
    Dim Applications_Item As Object
    Dim Blist As Range
    Dim bAcct As Range, xcell As Range, HtmlContent, firstAddress
    Dim Key As Variant
    Dim lastRow As Long
    Dim dict
    Dim attPath As String
    Dim subjectMS, bodyGS 
    
    Set Applications = CreateObject("Outlook.Application")
    
    lastRow = Sheet2.Cells(Rows.Count, "B").End(xlUp).Row
    Set Blist = Sheet2.Range("B2:B" & lastRow)

    Set dict = CreateObject("Scripting.Dictionary")
    For Each xcell In Blist
        If Not dict.Exists(CStr(xcell.Value)) Then
            dict.Add CStr(xcell.Value), 1        'CStr convert to account number to string for the dictionary
        End If
    Next xcell
    
    For Each Key In dict.Keys
    
        Set bAcct = Blist.Find(Key, LookIn:=xlValues)
        If Not bAcct Is Nothing Then
            Set Applications_Item = Applications.CreateItem(0)
            firstAddress = bAcct.Address
            Do
                HtmlContent = HtmlContent & "<table>" & _
                              "<table border='1' cellspacing='0' cellpadding=4'>" & _
                              "<tr><td><b> Transaction ID: </b></td><td>" & Sheet2.Range("C" & bAcct.Row).Value & _
                              "</td><td>" & Sheet2.Range("M" & bAcct.Row).Value & "</td></tr>" & _
                              "<tr><td><b> Transaction Amount: </b></td><td>" & Sheet2.Range("K" & bAcct.Row).Value & "</td><td>" & _
                              Sheet2.Range("T" & bAcct.Row).Value & " " & Sheet2.Range("W" & bAcct.Row).Value & "</td></tr>" & _
                              "<tr><td><b> Transaction Date: </b></td><td>" & Sheet2.Range("J" & bAcct.Row).Value & "</td><td>" & _
                              Sheet2.Range("U" & bAcct.Row).Value & "</td></tr>" & _
                              "</table>" & "<br> "
                                        
                'Attachment
                attPath = "C:\Users\main\Desktop\sus trx\"
                Applications_Item.Attachments.Add attPath & Sheet2.Range("O" & bAcct.Row).Value
                
                ' append values of columns M-S to subject and G-S to body
                subjectMS = subjectMS & ", " & Sheet2.Range("M" & bAcct.Row).Value & ":" & Sheet2.Range("S" & bAcct.Row).Value
                bodyGS = bodyGS & ", " & Sheet2.Range("G" & bAcct.Row).Value & " - " & Sheet2.Range("H" & bAcct.Row).Value
                
                Set bAcct = Blist.FindNext(bAcct)
            Loop While Not bAcct Is Nothing And bAcct.Address <> firstAddress
        End If
        
        With Applications_Item
            .To = "[email protected]"
            '.CC
            .Subject = "#" & Sheet2.Range("B" & bAcct.Row).Value & " - " & Mid(subjectMS, 2)
            .HTMLBody = "Dear our valued customer, " & "<br>" & "<br>" & "We have registered a suspicious transaction from your account with number(s): " & _
                        "<b>" & Mid(bodyGS, 2) & "</b>" & _
                        ". The information is as follows: " & "<br>" & "<br>" & "------Transaction Summary-------" & "<br>" & "<br>" & _
                        HtmlContent & "<br>" & "<br>" & "Thank you" & "<br>" & "Best regards,"
            .Display   'comment out and use .send after testing
            '.Send
        End With
        HtmlContent = ""
        subjectMS = ""
        bodyGS = ""
    Next Key
            
    Set Applications = Nothing
    Set Applications_Item = Nothing
    Set dict = Nothing

End Sub