Microsoft 365 Création de segments se basant sur plusieurs colonnes

Option Explicit
Option Compare Text 'la casse est ignorée
Dim T, ncol%, a(), n& 'mémorise les variables

Private Sub OptionButton1_Change()
ComboBox1_GotFocus
ComboBox1_Change
End Sub

Private Sub ComboBox1_GotFocus()
Dim tablo, i&, j%, k%
With [Tableau1]
    T = .Value 'matrice, plus rapide
    ncol = .Columns.Count
    tablo = IIf(OptionButton1, .Resize(, 2), .Columns(3).Resize(, 3))
End With
Erase a: n = 0
For i = 1 To UBound(tablo)
    For j = 1 To UBound(tablo, 2)
        If tablo(i, j) <> "" Then
            n = n + 1
            ReDim Preserve a(1 To 2, 1 To n)
            a(1, n) = tablo(i, j)
            a(2, n) = i 'mémorise la ligne
        End If
Next j, i
If n Then ComboBox1.List = Application.Index(a, 1, 0) Else ComboBox1.Clear
End Sub

Private Sub ComboBox1_Change()
Dim crit$, d As Object, resu(), i&, j%, lig&, col%
crit = "*" & ComboBox1 & "*"
If n Then
    Set d = CreateObject("Scripting.Dictionary")
    ReDim resu(1 To UBound(T), 1 To ncol)
    For i = 1 To UBound(a, 2)
        If a(1, i) Like crit Then
            If Not d.exists(a(2, i)) Then
                d(a(2, i)) = 0
                lig = lig + 1
                For col = 1 To ncol
                    resu(lig, col) = T(a(2, i), col)
                Next col
            End If
        End If
    Next i
End If
'---restitution---
With [Tableau2] 'tableau structuré
    If lig Then .Resize(lig, ncol) = resu
    If .ListObject.DataBodyRange Is Nothing Then Exit Sub
    If lig < .Rows.Count Then .Rows(lig + 1).Resize(.Rows.Count - lig).Delete xlUp
End With
End Sub