Sub Filtre()
Dim dep As Range, plage1 As Range, plage2 As Range, txt$
Sheets("Carte").Activate
If [N6] = "" Then Set cel = [N6]
On Error Resume Next 'si Caller n'est pas une shape
cel = Right(Application.Caller, 2)
If Err = 0 Then Set cel = cel.Offset(1)
On Error GoTo 0
If [N6] = "" Or ActiveSheet.CommandButton1.Caption Like "Arr*" Then Exit Sub
For Each dep In Range("N6", cel)
If dep = "" Then Exit For
With Sheets("Base")
.AutoFilterMode = False
Set plage1 = .Range("G1", .[G65536].End(xlUp))
plage1.AutoFilter 1, "*" & dep & "*"
Set plage1 = plage1.SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
If plage1.Count > 1 Then _
Set plage2 = Union(plage1, IIf(plage2 Is Nothing, plage1, plage2))
Next
With Sheets("Filtre")
.[2:65536].Delete
txt = Trim(Join(Application.Transpose(Range("N6", cel))))
If plage2 Is Nothing Then MsgBox "Aucun contact en " & txt & "...": GoTo 1
plage2.EntireRow.Copy .[A1]
Set plage2 = .[B2:C2].Resize(plage2.Count - 1)
plage2.Name = "Contacts"
End With
With UserForm1
.Caption = "Contacts en " & txt
.Height = 122.25
.Show
End With
1 Range("N6", cel).ClearContents
End Sub