VBA-lenteur de delete

[nadir****]

Bonjour.
J'ai l'impression que la methode delete est lente en VBA.
Voilà un petit programme qui supprime les lignes identiques d'une plage de cellule.
Si cette plage est grande, le temps d'exécution est vraiment long.
Est-ce que quelqu'un a une idée pour l'accélérer ?
Voici le code:

Public Sub ColonneSupr()

Dim Tableau As Range
Dim i As Integer, j As Integer
Dim Test As Boolean

Set Tableau = Range("A1").CurrentRegion                                 ' Définit la région
For i = Tableau.Rows.Count To 2 Step -1
    Test = True
    For j = 1 To Tableau.Columns.Count                                  'Vérifie si la ligne i est identique à la i-1
        If Tableau(i, j) <> Tableau(i - 1, j) Then Test = False
    Next
    If Test Then Tableau.Rows(i).Delete                                 'si oui, supprimer la ligne i
Next

End Sub

 

[phlaurent55]

Re : VBA-lenteur de delete

Bonjour nadir,

déjà avec ceci:

Public Sub ColonneSupr()
[B][COLOR=blue]Application.ScreenUpdating = False[/COLOR][/B]
Dim Tableau As Range
Dim i As Integer, j As Integer
Dim Test As Boolean
 
Set Tableau = Range("A1").CurrentRegion                                 ' Définit la région
For i = Tableau.Rows.Count To 2 Step -1
    Test = True
    For j = 1 To Tableau.Columns.Count                                  'Vérifie si la ligne i est identique à la i-1
        If Tableau(i, j) <> Tableau(i - 1, j) Then Test = False
    Next
    If Test Then Tableau.Rows(i).Delete                                 'si oui, supprimer la ligne i
Next
[B][COLOR=#0000ff]Application.ScreenUpdating = True[/COLOR][/B]
End Sub

cela évitera le raffraichissement d'écran à chaque suppression de ligne

à+
Philippe

 

[nadir****]

Re : VBA-lenteur de delete

Effectivement.
C'est beaucoup mieux.
Merci Philippe.

 

[homepyrof53]

Re : VBA-lenteur de delete

Bonjour,
Tu peux aussi interdire le calcul à chaque suppression de zone
au début de la macro :
Application.Calculation = xlCalculationManual


et à la fin
Application.Calculation =xlCalculationAutomatic

 

[Guest]

Re : VBA-lenteur de delete

Bonjour Nadir, Philippe.

Nadir, si tu as de la place libre 2 colonnes à droite de ton tableau tu peux essayer cette extraction sans doublon, très rapide.

copie provisoirement les données uniques à droite du tableau,
vide le tableau
et remet les données uniques extraites.

Sub ExtraireUniques()
    Dim plage As Range
    Set plage = Range("A1").CurrentRegion
    With plage
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Offset(, .Columns.Count + 2), Unique:=True
        .ClearContents
        .Offset(, .Columns.Count + 2).CurrentRegion.Cut Destination:=.Cells(1)
    End With
End Sub

A+

 

[nadir****]

Re : VBA-lenteur de delete

Hasco, Philippe.
Je reviens sur le problème de lenteur de delete.
L'extraction est vraiment, vraiment plus rapide effectivement pour ne garder que les valeurs uniques.
Mais comment extraire les lignes qui sont différentes à la suite l'une de l'autre (si n lignes qui se suivent sont identiques; il faut n'en garder qu'une).
Est-ce possible plus rapidement qu'avec le code que j'ai proposé dans mon message précédent ?
Merci.
Nadir.

 

[laetitia90]

Re : VBA-lenteur de delete

bonjour nadir****,homepyrof53,Hasco,phlaurent55

question tu as combien de colonne dans ton tableau??

 

[nadir****]

Re : VBA-lenteur de delete

Bonjour Laetitia.

C'est variable. C'est pourquoi j'utilise Tableau.Columns.Count

 

[Efgé]

Re : VBA-lenteur de delete

Bonjour bonjour nadir****, homepyrof53, Hasco, phlaurent55, laetitia90,
Pour gagner un pouillème on peut faire:

    For j = 1 To Tableau.Columns.Count 
        If Tableau(i, j) <> Tableau(i - 1, j) Then Test = False
        [B][COLOR=blue]Exit For
[/COLOR][/B]    Next

Cordialement

 

[nadir****]

Re : VBA-lenteur de delete

Bonjour à tous.
Merci Efgé.
Je pense qu'on peut y arriver efficacement avec Advancedfilter.
Je planche la dessus et si j'y arrive, le donnerai la solution que j'ai trouvé.

 

[laetitia90]

Re : VBA-lenteur de delete

re,
bonjour Efgé

Sub es()
Dim t As Variant, t2() As Variant, x As Long, i As Long, k As Long
Dim c As Byte, z As Byte, m As Object, y As Byte, r As Long
 On Error Resume Next
 Application.ScreenUpdating = False
 r = Cells.Find("*", , , , , xlPrevious).Row
y = Range("a1").CurrentRegion.Columns.Count + 1
Set m = CreateObject("Scripting.Dictionary")
t = Range(Cells(1, 1), Cells(r, y))
x = 1
For i = 1 To UBound(t)
z = 0
 For c = 1 To y - 1
  t(i, y) = t(i, y) & t(i, c)
  Next c
If Not m.Exists(t(i, y)) Then
m.Add t(i, y), t(i, y)
ReDim Preserve t2(1 To y - 1, 1 To x)
For k = 1 To y - 1: t2(k, x) = t(i, k): Next k: x = x + 1: End If: Next i
Cells.Clear
Range("a1").Resize(UBound(t2, 2), UBound(t2, 1)) = Application.Transpose(t2)
Erase t, t2: Set m = Nothing: Beep
End Sub

 

[nadir****]

Re : VBA-lenteur de delete

Bonjour Laetitia.
Je vais me plonger dans ton code pour essayer de le comprendre.
Plus simplement, j'ai essayé d'utiliser Advancedfilter.
J'ai d'abord
-"écrit" les critères de sélection "sous" le tableau
- puis j'ai filtré
- et enfin j'ai remis tout à sa place.
Voici mon code.

Sub triefficace()
'
Dim Plage As Range, Criteres As Range, Resultats As Range
Dim Critere As String
Dim j As Integer

Set Plage = Range("A1").CurrentRegion                  'Définition la plage à filtrer
Plage.Rows(2).Insert Shift:=xlDown                      'Insère une ligne pour ne pas supprimer la 1ere ligne de résultats

Set Resultats = Plage(1, Plage.Columns.Count + 2)       'Positionne le tableau de résultats
                                                        
For j = 3 To Plage.Columns.Count                                   'Crée les critères en chaine de caratères
    Plage(Plage.Rows.Count + j, j) = "=" & _
            Plage(1, j).Address(RowAbsolute:=False, ColumnAbsolute:=False) _
            & "<>" & _
            Plage(2, j).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Next
                                                        'Définition de la zone de critères
Set Criteres = Range(Plage(Plage.Rows.Count + 2, 3), _
                Plage(Plage.Rows.Count + Plage.Columns.Count, Plage.Columns.Count))

                                                        'Filtrage
Plage.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Criteres, CopyToRange:=Resultats, Unique:=False

Set Resultats = Resultats.CurrentRegion                 'Etend la zone de résultats
Criteres.ClearContents                                  'Efface la zone de critère
Plage.ClearContents                                     'Efface l'ancienne zone de plage
Resultats.Cut Destination:=Plage                        'Ecrit les résultats sur l'ancienne zone
Set Plage = Resultats                                   'Affecte à Plage les résultats

End Sub

Merci en tout cas de ton aide.
Nadir