XL 2016 Supprimer si identique dans autre plage

[KTM]

Bonjour cher tous
J'ai deux plages p1 =.[B1:E1000000] et p2 =.[H1:L10000]
Je voudrais supprimer les enregistrements dans p1 pour lesquelles le code est identique dans p2.
Merci

 

[KTM]

Essaie :

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

Merci Daniel
ENORMEMENT!!!

 

[job75]

Bonjour KTM, danielco, mapomme, le forum,

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é.

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 :

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+

 

[danielco]

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 :

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+

Clap, clap. Je me coucherai moins bête ce soir (l'utilisation du dictionnaire).

Daniel

 

[KTM]

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 :

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+

Merci Job 75