XL 2016 Supprimer si identique dans autre plage

job75 à dit:

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+

Cliquez pour agrandir...

3,90625E-03

Cliquez pour agrandir...

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

Cliquez pour agrandir...

danielco à dit:

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


Certes, mais personne n'a dit non plus qu'il faille en supprimer beaucoup.

Daniel

Cliquez pour agrandir...

job75 à dit:

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+

Cliquez pour agrandir...

KTM à dit:

Merci danielco ; l'observation de Job 75 est à considérer car j"ai des plages vraiment énormes !

Cliquez pour agrandir...

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

danielco à dit:

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

Cliquez pour agrandir...

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

danielco à dit:

On ne teste pas la même chose, ma mesure était pour 1 match sur une colonne de 1000000 cellules.

Cliquez pour agrandir...

job75 à dit:

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.

Cliquez pour agrandir...

job75 à dit:

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.

Cliquez pour agrandir...

job75 à dit:

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.

Cliquez pour agrandir...