Sub Test()
Dim PlgEmp As Range, TClés(), L&, C&, TEmp(), Clé, D As New Scripting.Dictionary, CelRés As Range
TClés = Feuil1.[A4:A18].Value
Set PlgEmp = Feuil1.[F3:J5]: TEmp = PlgEmp.Value
For L = 1 To UBound(TEmp, 1)
For C = 1 To UBound(TEmp, 2)
Clé = TClés(TEmp(L, C), 1)
If D.Exists(Clé) Then
Set CelRés = PlgEmp(L, C)
If D(Clé) <> L Then
Set CelRés = PlgEmp(L, C)
L = D(Clé)
C = 1: Do While TClés(TEmp(L, C), 1) <> Clé: C = C + 1: Loop
Set CelRés = Union(PlgEmp(L, C), CelRés): Application.Goto CelRés
MsgBox "Ligne différentes pour emplacements de """ & Clé & """." _
& vbLf & "Cellules: " & CelRés.Address(0, 0), _
vbInformation, "Test": Exit Sub: End If
Else
D(Clé) = L
End If: Next C, L
End Sub
Sub Test2()
Dim PlgEmp As Range, TClés(), L&, C&, TEmp(), Clé, D As New Scripting.Dictionary, CelRés As Range
TClés = Feuil1.[A4:A18].Value
Set PlgEmp = Feuil1.[F3:J5]: TEmp = PlgEmp.Value
For L = 1 To UBound(TEmp, 1)
For C = 1 To UBound(TEmp, 2)
Clé = TClés(TEmp(L, C), 1)
If Not D.Exists(Clé) Then
D(Clé) = L
ElseIf D(Clé) <> L Then
Set CelRés = PlgEmp(L, C): GoTo Zut: End If: Next C, L
Exit Sub
Zut: For L = 1 To UBound(TEmp, 1)
For C = 1 To UBound(TEmp, 2)
If TClés(TEmp(L, C), 1) = Clé Then Set CelRés = Union(PlgEmp(L, C), CelRés)
Next C, L
Application.Goto CelRés
MsgBox "Lignes différentes pour emplacements de """ & Clé & """." _
& vbLf & "Cellules: " & CelRés.Address(0, 0), vbInformation, "Test"
End Sub