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
Bonjour @job75Bonjour 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+
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).3,90625E-03
Certes, mais personne n'a dit non plus qu'il faille en supprimer beaucoup.Et supprimer les lignes une par une encore plus s'il faut en supprimer beaucoup.
Merci danielco ; l'observation de Job 75 est à considérer car j"ai des plages vraiment énormes !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
Salut Job 75Bonjour 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+
Essaie :Merci danielco ; l'observation de Job 75 est à considérer car j"ai des plages vraiment énormes !
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
Remplissez la plage H2:H10000 et mettez zzz en H5000, puis testez :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).
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
Avec votre macro du post #2 il y aura 1000 000 Match sur une colonne de 10 000 cellules.On ne teste pas la même chose, ma mesure était pour 1 match sur une colonne de 1000000 cellules.
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.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.
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
Merci Job 75Avec 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.
Merci Job 75Voyez le fichier joint et cette macro :
Elle prend 2,4 secondes chez moi sur 999 999 lignes.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
Bien noter que les formats sont conservés.