XL 2016 Supprimer si identique dans autre plage

danielco à dit:

Essaie :

VB:

Option Base 1
Sub test()
  Dim Tabl1 As Variant, Tabl2 As Variant, Tabl3(), I As Long, J As Long
  Dim Teste As Boolean, Ctr As Long
  Tabl1 = Range("B2", Cells(Rows.Count, 5).End(xlUp))
  Tabl2 = Application.Transpose(Range("H2", Cells(Rows.Count, 8).End(xlUp)))
  For I = 1 To UBound(Tabl1, 1)
    Teste = False
    For J = 1 To UBound(Tabl2)
      If Tabl1(I, 1) = Tabl2(J) Then
        Teste = True
        Exit For
      End If
    Next J
    If Teste = False Then
      Ctr = Ctr + 1
      ReDim Preserve Tabl3(4, Ctr)
      Tabl3(1, Ctr) = Tabl1(I, 1)
      Tabl3(2, Ctr) = Tabl1(I, 2)
      Tabl3(3, Ctr) = Tabl1(I, 3)
      Tabl3(4, Ctr) = Tabl1(I, 4)
    End If
  Next I
  Range("B2", Cells(Rows.Count, 5).End(xlUp)) = ""
  [B2].Resize(UBound(Tabl3, 2), UBound(Tabl3, 1)) = Application.Transpose(Tabl3)
End Sub

Daniel

Cliquez pour agrandir...

mapomme à dit:

A part ajouter une colonne temporaire, je ne sais pas conserver l'ordre initial des lignes lors du tri, du-moins je n'ai pas trouvé.

Cliquez pour agrandir...

Sub Supprimer()
Dim t#, d As Object, tablo, i&, x$, P As Range, resu(), n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
With Feuil1 'CodeName à adapter
    '---liste sans doublon---
    tablo = .[H2:H10000] 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = tablo(i, 1)
        If x <> "" Then d(x) = ""
    Next
    '---repérage des lignes à conserver---
    Set P = .[B2:E1000000] '999 999 lignes...
    tablo = P.Columns(1) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 1 To UBound(tablo)
        x = tablo(i, 1)
        If x <> "" Then If d.Exists(x) Then n = n + 1 Else resu(i, 1) = 1 'repère
    Next
    '---restitution, tri et suppression---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    P.Columns(2).EntireColumn.Insert 'colonne auxiliaire
    P.Columns(2) = resu
    P.Sort P(1, 2), Header:=xlNo 'tri pour regrouper les 1 et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow, P).Delete xlUp 'supprime les cellules vides
    P.Columns(2).EntireColumn.Delete 'supprime la colonne auxiliire
    With .UsedRange: End With 'actualise les barres de défilement
End With
MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub

job75 à dit:

Bonjour KTM, danielco, mapomme, le forum,

Avec la macro précédente le tableau est trié sur la colonne B, ça ne me paraît pas gênant.

Maintenant si vous voulez conserver l'ordre initial prenez ce fichier (2) et la macro :

VB:

Sub Supprimer()
Dim t#, d As Object, tablo, i&, x$, P As Range, resu(), n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
With Feuil1 'CodeName à adapter
    '---liste sans doublon---
    tablo = .[H2:H10000] 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = tablo(i, 1)
        If x <> "" Then d(x) = ""
    Next
    '---repérage des lignes à conserver---
    Set P = .[B2:E1000000] '999 999 lignes...
    tablo = P.Columns(1) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 1 To UBound(tablo)
        x = tablo(i, 1)
        If x <> "" Then If d.Exists(x) Then n = n + 1 Else resu(i, 1) = 1 'repère
    Next
    '---restitution, tri et suppression---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    P.Columns(2).EntireColumn.Insert 'colonne auxiliaire
    P.Columns(2) = resu
    P.Sort P(1, 2), Header:=xlNo 'tri pour regrouper les 1 et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow, P).Delete xlUp 'supprime les cellules vides
    P.Columns(2).EntireColumn.Delete 'supprime la colonne auxiliire
    With .UsedRange: End With 'actualise les barres de défilement
End With
MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub

On utilise une colonne auxiliaire, ça prend un peu plus de temps : 2,9 secondes.

A+

Cliquez pour agrandir...

job75 à dit:

Bonjour KTM, danielco, mapomme, le forum,

Avec la macro précédente le tableau est trié sur la colonne B, ça ne me paraît pas gênant.

Maintenant si vous voulez conserver l'ordre initial prenez ce fichier (2) et la macro :

VB:

Sub Supprimer()
Dim t#, d As Object, tablo, i&, x$, P As Range, resu(), n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
With Feuil1 'CodeName à adapter
    '---liste sans doublon---
    tablo = .[H2:H10000] 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = tablo(i, 1)
        If x <> "" Then d(x) = ""
    Next
    '---repérage des lignes à conserver---
    Set P = .[B2:E1000000] '999 999 lignes...
    tablo = P.Columns(1) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 1 To UBound(tablo)
        x = tablo(i, 1)
        If x <> "" Then If d.Exists(x) Then n = n + 1 Else resu(i, 1) = 1 'repère
    Next
    '---restitution, tri et suppression---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    P.Columns(2).EntireColumn.Insert 'colonne auxiliaire
    P.Columns(2) = resu
    P.Sort P(1, 2), Header:=xlNo 'tri pour regrouper les 1 et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow, P).Delete xlUp 'supprime les cellules vides
    P.Columns(2).EntireColumn.Delete 'supprime la colonne auxiliire
    With .UsedRange: End With 'actualise les barres de défilement
End With
MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub

On utilise une colonne auxiliaire, ça prend un peu plus de temps : 2,9 secondes.

A+

Cliquez pour agrandir...