Sub Transfert2()
Dim ncol%, source As Range, dest As Range, tablo, resu(), d As Object, n&, i&, nn&, j%
ncol = 4 'nombre de colonnes il faut prendre jusqu'à la colonne D
Set source = Sheets("Template").[A1].CurrentRegion.Resize(, ncol)
Set dest = Sheets("Destination").Range("A" & Rows.Count).End(xlUp)(2) '1ère cellule vide
tablo = source 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
d("Transporta") = "": d("Holdingb") = "": d("AutresDacom") = "": d("HoldingDomaine.net") = "" 'créer une clé pour chaque critère
n = 1
For i = 2 To UBound(tablo)
If d.exists(tablo(i, 1) & tablo(i, 2)) Or d.exists(tablo(i, 1) & Split(tablo(i, 4), "@")(1)) Then
nn = nn + 1
For j = 1 To ncol
resu(nn, j) = tablo(i, j)
Next j
Else
n = n + 1
For j = 1 To ncol
tablo(n, j) = tablo(i, j)
Next j
End If
Next i
'---restitution des 2 tableaux---
If source.Parent.FilterMode Then source.Parent.ShowAllData 'si la feuille est filtrée
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
source.Resize(n) = tablo
source.Offset(n).Resize(Rows.Count - n - source.Row + 1).ClearContents 'RAZ en dessous
If nn Then dest.Resize(nn, ncol) = resu
dest.Offset(nn).Resize(Rows.Count - nn - dest.Row + 1, ncol).ClearContents 'RAZ en dessous
MsgBox nn & " ligne(s) sur " & n - 1 + nn & " transférée(s)..."
End Sub