Sub References_communes()
Dim w As Worksheet, cible1 As Range, fichier$, wb As Workbook, cible2 As Range, d As Object, tablo, i&, x$
'---fichier à comparer---
For Each w In ThisWorkbook.Worksheets
Set cible1 = w.Cells.Find("CODE EAN", , xlValues, xlWhole)
If Not cible1 Is Nothing Then Exit For
Next w
If cible1 Is Nothing Then MsgBox "'CODE EAN' introuvable !", 48: Exit Sub
'--- fichier source---
fichier = "références internes.xlsx"
For Each wb In Workbooks
If LCase(wb.Name) = fichier Then Exit For
Next wb
If wb Is Nothing Then MsgBox "Ouvrez le fichier '" & fichier & "' !", 48: Exit Sub
For Each w In wb.Worksheets
Set cible2 = w.Cells.Find("CODE EAN", , xlValues, xlWhole)
If Not cible2 Is Nothing Then Exit For
Next w
If cible2 Is Nothing Then MsgBox "'CODE EAN' introuvable dans '" & fichier & "' !", 48: Exit Sub
'---colonne source--
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Intersect(cible2.EntireColumn, w.UsedRange).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
x = CStr(tablo(i, 1))
If x <> "" Then d(x) = ""
Next i
'---colonne à comparer---
Application.ScreenUpdating = False
Application.Goto cible1 'active la feuille
With cible1.EntireColumn
.Insert 'colonne auxiliaire
With Intersect(.Offset(, -1).Resize(, 2), ActiveSheet.UsedRange.EntireRow)
tablo = .Value
For i = 1 To UBound(tablo)
x = CStr(tablo(i, 2))
If d.exists(x) Then tablo(i, 1) = 1 'repère
Next
.Value = tablo 'restitution
.Columns(1).SpecialCells(xlCellTypeConstants).Select 'sélection recherchée
.Columns(1).EntireColumn.Delete 'supprime la colonne auxiliaire
End With
End With
End Sub