XL 2016 Supprimer si identique dans autre plage

KTM

XLDnaute Impliqué
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
 

Pièces jointes

  • suppr.xlsm
    17.3 KB · Affichages: 27

danielco

XLDnaute Accro
Bonjour,

Essaie :

VB:
Sub test()
  Dim C As Range, Tabl As Variant, I As Long
  Tabl = Application.Transpose(Range("H2", Cells(Rows.Count, 8).End(xlUp)))
  For I = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
    If IsNumeric(Application.Match(Cells(I, 2), Tabl, 0)) Then
      Cells(I, 2).Resize(, 4).Delete xlShiftUp
    End If
  Next I
End Sub

Cordialement.

Daniel
 

job75

XLDnaute Barbatruc
Bonjour KTM, danielco,

@danielco je suis étonné que vous ne sachiez pas que Application.Match sur 1 000 000 de lignes va prendre beaucoup de temps.

Et supprimer les lignes une par une encore plus s'il faut en supprimer beaucoup.

Pour aller vite il faut des tableaux VBA et un Dictionary, nombreux exemples sur XLD.

A+
 

danielco

XLDnaute Accro
Bonjour KTM, danielco,

@danielco je suis étonné que vous ne sachiez pas que Application.Match sur 1 000 000 de lignes va prendre beaucoup de temps.

Et supprimer les lignes une par une encore plus s'il faut en supprimer beaucoup.

Pour aller vite il faut des tableaux VBA et un Dictionary, nombreux exemples sur XLD.

A+
Bonjour @job75
Non. il s'agit d'un Match sur un tableau VBA, justement (La plupart du temps, le timer affiche 0 ; dans le cas le plus défavorable 4/1000 de sec).

Et supprimer les lignes une par une encore plus s'il faut en supprimer beaucoup.
Certes, mais personne n'a dit non plus qu'il faille en supprimer beaucoup.

Daniel
 

KTM

XLDnaute Impliqué
Bonjour KTM, danielco,

@danielco je suis étonné que vous ne sachiez pas que Application.Match sur 1 000 000 de lignes va prendre beaucoup de temps.

Et supprimer les lignes une par une encore plus s'il faut en supprimer beaucoup.

Pour aller vite il faut des tableaux VBA et un Dictionary, nombreux exemples sur XLD.

A+
Salut Job 75
Heureux de vous revoir !
J'attends votre astuce
Merci.
 

danielco

XLDnaute Accro
Merci danielco ; l'observation de Job 75 est à considérer car j"ai des plages vraiment énormes !
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
 

job75

XLDnaute Barbatruc
Je ne peux pas laisser passer ça :
Non. il s'agit d'un Match sur un tableau VBA, justement (La plupart du temps, le timer affiche 0 ; dans le cas le plus défavorable 4/1000 de sec).
Remplissez la plage H2:H10000 et mettez zzz en H5000, puis testez :
VB:
Sub a()
Dim t, n, i
t = Timer
For n = 1 To 1000000
    i = Application.Match("zzz", Range("H2:H10000"), 0)
Next
MsgBox Timer - t '42 secondes chez moi
End Sub

Sub b()
Dim t, n, i
t = Timer
tablo = Range("H2:H10000")
For n = 1 To 1000000
    i = Application.Match("zzz", tablo, 0)
Next
MsgBox Timer - t '427 secondes chez moi
End Sub
Chez moi a => 42 secondes, b=> 427 secondes
 

job75

XLDnaute Barbatruc
On ne teste pas la même chose, ma mesure était pour 1 match sur une colonne de 1000000 cellules.
Avec votre macro du post #2 il y aura 1000 000 Match sur une colonne de 10 000 cellules.

Pour la macro post #7 utiliser une 2ème boucle imbriquée n'est pas mieux que Application.Match.

Il faut tester les codes que vous donnez avec les dimensions réelles des tableaux.
 

danielco

XLDnaute Accro
Avec votre macro du post #2 il y aura 1000 000 Match sur une colonne de 10 000 cellules.

Pour la macro post #7 utiliser une 2ème boucle imbriquée n'est pas mieux que Application.Match.

Il faut tester les codes que vous donnez avec les dimensions réelles des tableaux.
Pour le premier code, je n'avais pas remarqué la taille importante des tableaux. Seulement travaillé sur le classeur fourni. Pour le second, je ne sais pas faire mieux. j'attends ta solution.
Daniel
 

job75

XLDnaute Barbatruc
Voyez le fichier joint et cette macro :
VB:
Sub Supprimer()
Dim t#, d As Object, tablo, i&, P As Range, 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)
        If tablo(i, 1) <> "" Then d(tablo(i, 1)) = ""
    Next
    '---repérage des lignes à supprimer---
    Set P = .[B2:E1000000] '999 999 lignes...
    tablo = P.Columns(1) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If d.Exists(tablo(i, 1)) Then n = n + 1: tablo(i, 1) = "#N/A" 'repère
    Next
    '---restitution, tri et suppression---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    P.Columns(1) = tablo
    P.Sort P(1), xlAscending, Header:=xlNo 'tri pour regrouper les #N/A et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P.SpecialCells(xlCellTypeConstants, 16).EntireRow, P).Delete xlUp
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub
Elle prend [Edit] 2,7 secondes chez moi sur 999 999 lignes.

Bien noter que les formats sont conservés.
 

Pièces jointes

  • suppr(1).xlsm
    24.9 KB · Affichages: 7
Dernière édition:

KTM

XLDnaute Impliqué
Voyez le fichier joint et cette macro :
VB:
Sub Supprimer()
Dim t#, d As Object, tablo, i&, P As Range, 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)
        If tablo(i, 1) <> "" Then d(tablo(i, 1)) = ""
    Next
    '---repérage des lignes à supprimer---
    Set P = .[B2:E1000000] '999 999 lignes...
    tablo = P.Columns(1) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If d.Exists(tablo(i, 1)) Then n = n + 1: tablo(i, 1) = "#N/A" 'repère
    Next
    '---restitution, tri et suppression---
    Application.ScreenUpdating = False
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    P.Columns(1) = tablo
    P.Sort P(1), xlAscending, Header:=xlNo 'tri pour regrouper les #N/A et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P.SpecialCells(xlCellTypeConstants, 16).EntireRow, P).Delete xlUp
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
MsgBox n & " ligne" & IIf(n > 1, "s", "") & " supprimée" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub
Elle prend 2,4 secondes chez moi sur 999 999 lignes.

Bien noter que les formats sont conservés.
Merci Job 75
Je vais expérimenter et vous revenir
 

Discussions similaires

Réponses
10
Affichages
298
Réponses
7
Affichages
292

Statistiques des forums

Discussions
311 720
Messages
2 081 898
Membres
101 834
dernier inscrit
Jeremy06510