Groep afzenders apart markeren

Option Explicit

Public Sub AddExcelToRule()
    
    Dim aData As Variant
    Dim iaData As Long
    Dim oExcel As Object
    Dim oRecipient As Object
    Dim sPath As String
    Dim sRecipient As String
    Dim sRule As String

    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")
    On Error GoTo 0
    If oExcel Is Nothing Then
        Set oExcel = CreateObject("Excel.Application")
    End If
    With oExcel
        With .FileDialog(3)
            .AllowMultiSelect = False
            If .Show Then
                sPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        With .Workbooks.Open(sPath)
            aData = .WorkSheets(1).Range("A1").CurrentRegion
            .Application.Quit
        End With
        With Application.Session.DefaultStore.GetRules()
            For iaData = 2 To UBound(aData)
                sRule = aData(iaData, 1)
                sRecipient = aData(iaData, 2)
                With .Item(sRule)
                    With .Conditions.From
                        For Each oRecipient In .Recipients
                            If oRecipient = sRecipient Then
                                GoTo RecipientFound
                            End If
                        Next
                        .Recipients.Add sRecipient
                        .Recipients.ResolveAll
                    End With
                End With
                .Save
RecipientFound:
            Next
        End With
    End With

End Sub