XL 2019 traiter liste de choix multiples

(les départements sans contrainte de date et ceux avec). Pour info les noms et adresses mails sont évidemment fictifs

Sub Filtrer()
'Déclaration de deux dictionnaires qui contiendront les noms
Dim DicoSansContrainte As Object
Dim DicoAvecContrainte As Object

Dim TabData() As Variant 'déclaration d'un tablo VBA pour y mettre toute la feuille "Liste"

'création des dictionnaires
Set DicoSansContrainte = CreateObject("scripting.dictionary")
Set DicoAvecContrainte = CreateObject("scripting.dictionary")

With Sheets("Liste") 'avec la feuille Liste
    'on détecte la zone complète qui contient des noms
    LastLine = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne NON vide de la colonne A
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'dernière colonne NON vide de la ligne 1
    TabData = .Range("A2").Resize(LastLine - 1, LastCol).Value 'on met toute la zone détectée dans le tablo VBA
    'du fait des cellules fusionnées sur 2 lignes, la seconde ligne est "normalement" vide==> on recopie chaque nom sur 2 lignes
    For i = LBound(TabData, 1) To UBound(TabData, 1) 'pour chaque ligne du tablo VBA
        If TabData(i, 1) = "" Then TabData(i, 1) = TabData(i - 1, 1)
    Next i
End With

With Sheets("Recherche") 'avec la feuille Recherche
    .UsedRange.Offset(3).Clear 'on efface tout sauf les 3 premières lignes
    Département = .Range("B1") 'on récupère le département sélectionné en B1
    
    For i = LBound(TabData, 1) To UBound(TabData, 1) 'pour chaque ligne du tablo VBA
        For j = 4 To UBound(TabData, 2) 'pour chaque colonne (à partir de la colonne 4 = 1er choix)
            If TabData(i, j) = Département Then 'si le choix correspond au département
                clé = TabData(i, 1) 'on créé une clé avec le nom (en colonne 1)
                NomDico = IIf(InStr(1, TabData(i, 3), "sans") <> 0, "Sans", "Avec") 'on choisit le dictionnaire à utiliser selon si on trouve le mot "SANS" dans la colonne C
                If NomDico = "Sans" Then 'si on est sur le dico SANS
                    If Not DicoSansContrainte.exists(clé) Then 'on ajoute le nom dans le dico
                        DicoSansContrainte.Add clé, 1
                    End If
                Else 'on sur le dico "AVEC"
                    If Not DicoAvecContrainte.exists(clé) Then
                        DicoAvecContrainte.Add clé, i 'on ajoute le nom dans le dico
                    End If
                End If
            End If
        Next j
    Next i
    'on colle les résultats dans la feuille
    .Range("A4").Resize(DicoSansContrainte.Count, 1) = Application.WorksheetFunction.Transpose(DicoSansContrainte.keys)
    .Range("B4").Resize(DicoAvecContrainte.Count, 1) = Application.WorksheetFunction.Transpose(DicoAvecContrainte.keys)

End With
'on libère la mémoire
Set DicoSansContrainte = Nothing
Set DicoAvecContrainte = Nothing

End Sub

Sub Filtrer()
'Déclaration de deux dictionnaires qui contiendront les noms
Dim DicoSansContrainte As Object
Dim DicoAvecContrainte As Object

Dim TabData() As Variant 'déclaration d'un tablo VBA pour y mettre toute la feuille "Liste"

'création des dictionnaires
Set DicoSansContrainte = CreateObject("scripting.dictionary")
Set DicoAvecContrainte = CreateObject("scripting.dictionary")

With Sheets("Liste") 'avec la feuille Liste
    'on détecte la zone complète qui contient des noms
    LastLine = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'dernière ligne NON vide de la colonne A
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'dernière colonne NON vide de la ligne 1
    TabData = .Range("A2").Resize(LastLine - 1, LastCol).Value 'on met toute la zone détectée dans le tablo VBA
    'du fait des cellules fusionnées sur 2 lignes, la seconde ligne est "normalement" vide==> on recopie chaque nom sur 2 lignes
    For i = LBound(TabData, 1) To UBound(TabData, 1) 'pour chaque ligne du tablo VBA
        If TabData(i, 1) = "" Then TabData(i, 1) = TabData(i - 1, 1)
    Next i
End With

With Sheets("Recherche") 'avec la feuille Recherche
    .UsedRange.Offset(3).Clear 'on efface tout sauf les 3 premières lignes
    Département = .Range("B1") 'on récupère le département sélectionné en B1
    
    For i = LBound(TabData, 1) To UBound(TabData, 1) 'pour chaque ligne du tablo VBA
        For j = 4 To UBound(TabData, 2) 'pour chaque colonne (à partir de la colonne 4 = 1er choix)
            If TabData(i, j) = Département Then 'si le choix correspond au département
                clé = TabData(i, 1) 'on créé une clé avec le nom (en colonne 1)
                NomDico = IIf(InStr(1, TabData(i, 3), "sans") <> 0, "Sans", "Avec") 'on choisit le dictionnaire à utiliser selon si on trouve le mot "SANS" dans la colonne C
                If NomDico = "Sans" Then 'si on est sur le dico SANS
                    If Not DicoSansContrainte.exists(clé) Then 'on ajoute le nom dans le dico
                        DicoSansContrainte.Add clé, 1
                    End If
                Else 'on sur le dico "AVEC"
                    If Not DicoAvecContrainte.exists(clé) Then
                        DicoAvecContrainte.Add clé, i 'on ajoute le nom dans le dico
                    End If
                End If
            End If
        Next j
    Next i
    'on colle les résultats dans la feuille si il y a quelque chose à copier
    If DicoSansContrainte.Count <> 0 Then .Range("A4").Resize(DicoSansContrainte.Count, 1) = Application.WorksheetFunction.Transpose(DicoSansContrainte.keys)
    If DicoAvecContrainte.Count <> 0 Then .Range("B4").Resize(DicoAvecContrainte.Count, 1) = Application.WorksheetFunction.Transpose(DicoAvecContrainte.keys)

End With
'on libère la mémoire
Set DicoSansContrainte = Nothing
Set DicoAvecContrainte = Nothing

End Sub