Формирование писем из таблицы excel по условиям

Sub Отправить_письма_уникальным_адресатам()
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    For i = FirstRow To LastRow
        ' n-я строка письма: дело1, дата дела1, результат дела 1 , перевод строки
        T = Cells(i, 2) & " " & Cells(i, 4) & " " & Cells(i, 5) & vbCrLf
        ' (n+1)-я строка письма: дело2, дата дела2, результат дела 2
        T = T & Cells(i, 3) & " " & Cells(i, 6) & " " & Cells(i, 7) & vbCrLf
        vX = Trim$(Cells(i, 1))
        Dic.Item(vX) = Dic.Item(vX) & T
    Next i
    For Each vX In Dic.Keys
        With OutlookApp.CreateItem(olMailItem)
            .To = vX
            .Subject = "Результаты дел" 'Тема
            .Body = Dic.Item(vX)
            .Send
        End With
        For j = 1 To 30: DoEvents: Next
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing
End Sub

Sub Макрос1()
 
 
 Const olMailItem% = 0
    Const FirstRow% = 3
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 26).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    For i = FirstRow To LastRow
        ' n-я строка письма: дело1, дата дела1, результат дела 1 , перевод строки
        T = T & Cells(i, 3) & " " & Cells(i, 4) & " " & Cells(i, 9) & " " & Cells(i, 10) & " " & Cells(i, 18) & " " & Cells(i, 20) & vbCrLf
         '(n+1)-я строка письма: дело2, дата дела2, результат дела 2
        'T = T & Cells(i, 3) & " " & Cells(i, 4) & " " & Cells(i, 9) & " " & Cells(i, 10) & " " & Cells(i, 18) & " " & Cells(i, 20) & vbCrLf
         
        vX = Trim$(Cells(i, 26))
        
        Dic.Item(vX) = Dic.Item(vX) & T
    Next i
    For Each vX In Dic.Keys
          
          For i = FirstRow To LastRow
           
           If (Cells(i, 26) = vX) And (Not IsEmpty(Cells(i, 27))) Then
                    
           With OutlookApp.CreateItem(olMailItem)
            .to = Cells(i, 27).Value
            .Subject = "Уважаемый  " & vX 'Тема
            .Body = "  " & vbCrLf & vbCrLf & Dic.Item(vX)
            .display
           End With
        
           End If
          Next i
 
 
        
       
        'For j = 1 To 30: DoEvents: Next
 
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing
End Sub

Sub Макрос1()
 
 
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    For i = FirstRow To LastRow
        If Not IsEmpty(Cells(i, 2)) Then
            ' n-я строка письма: дело1, дата дела1, результат дела 1 , перевод строки
            T = Cells(i, 3) & " " & Cells(i, 5) & " " & Cells(i, 6) & vbCrLf
            '(n+1)-я строка письма: дело2, дата дела2, результат дела 2
            'T = T & Cells(i, 3) & " " & Cells(i, 4) & " " & Cells(i, 9) & " " & Cells(i, 10) & " " & Cells(i, 18) & " " & Cells(i, 20) & vbCrLf
 
            vX = Cells(i, 1) & "|" & Trim$(Cells(i, 2))
 
            Dic.Item(vX) = Dic.Item(vX) & T
        End If
    Next i
 
    For Each vX In Dic.Keys
        arr = Split(vX, "|")
        '        Debug.Print arr(1)
        '        Debug.Print arr(0)
        '        Debug.Print "  " & vbCrLf & vbCrLf & Dic.Item(vX)
 
        With OutlookApp.CreateItem(olMailItem)
            .to = arr(1)
            .Subject = "Уважаемый  " & arr(0)    'Тема
            .Body = "  " & vbCrLf & vbCrLf & Dic.Item(vX)
            .display
        End With
 
 
        'For j = 1 To 30: DoEvents: Next
 
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing
End Sub

Sub Макрос1()
 
 
    Const olMailItem% = 0
    Const FirstRow% = 2
    Dim i&, j&, LastRow&, T$, vX, OutlookApp As Object, Dic As Object, Dic2 As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    With ActiveSheet: LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row: End With
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1
    For i = FirstRow To LastRow
        ' n-я строка письма: дело1, дата дела1, результат дела 1 , перевод строки
        T = Cells(i, 3) & " " & Cells(i, 5) & " " & Cells(i, 6) & vbCrLf
        '(n+1)-я строка письма: дело2, дата дела2, результат дела 2
        'T = T & Cells(i, 3) & " " & Cells(i, 4) & " " & Cells(i, 9) & " " & Cells(i, 10) & " " & Cells(i, 18) & " " & Cells(i, 20) & vbCrLf
 
        vX = Cells(i, 1)
 
        Dic.Item(vX) = Dic.Item(vX) & T
        If Not IsEmpty(Cells(i, 2)) Then Dic2.Item(vX) = Cells(i, 2)
 
    Next i
 
    For Each vX In Dic.Keys
 
        If Len(Dic2.Item(vX)) Then
'            Debug.Print vX & " " & Dic2.Item(vX)
'            Debug.Print Dic.Item(vX)
 
                    With OutlookApp.CreateItem(olMailItem)
                        .to = Dic2.Item(vX)
                        .Subject = "Уважаемый  " & vX    'Тема
                        .Body = "  " & vbCrLf & vbCrLf & Dic.Item(vX)
                        .display
                    End With
        End If
 
        'For j = 1 To 30: DoEvents: Next
 
    Next vX
    Set OutlookApp = Nothing
    Set Dic = Nothing
End Sub