Aide pour gagner du temps execution macro 40 000 lignes?

[flint6593]

Bonsoir à tous!

Alors voilà mon soucis:

- J'ai des références colonne B
- J'ai des références associées colonne C (si présente, il peut y avoir des références B sans référence C)
- Les références de la colonne B peuvent être entre la ligne 1 et la ligne 40 000 (Il peut avoir plusieurs cellules vides entres deux pleines)
- Je ne peux pas avoir de références C sans avoir la B

Le but: Ne garder que les cellules qui ont les deux références (sans les dissocier, exemple trier B puis C)

Donc mon idée:
- Trier sur la colonne B pour enlever les vide (et garder C associé)
- Selectionner la dernière cellule B, aller en C et remonter jusqu'au début en supprimant les cellules vides!

Tout fonctionne, mais pour 40000 lignes je suis dans des temps à 50s avec mon pc... Savez-vous, si c'est possible, d'améliorer ce temps? Peut-être avec un autre système, une autre méthode?
C'est que ce bout de code vient dans un code beaucoup plus gros...

Merci!!!!

En pj mon classeur:

 

[DoubleZero]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour, flint6593, le Forum,

Peut-être ainsi :

Sub Vides_supprimer()
Application.ScreenUpdating = 0
[c:c].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = -1
End Sub

A bientôt

 

[ROGER2327]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonsoir à tous

...ou peut-être ainsi :

Sub mef()
Dim x As Range
    With Sheets("Feuil2").Columns("B:C")
        .Sort Key1:=.Offset(0, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        Set x = .Cells(1, 1).Offset(Rows.Count - 1, 0)
        .Range(x.Offset(0, 1).End(xlUp), x.End(xlUp)).Offset(1, 0).EntireRow.Delete
    End With
End Sub

ROGER2327
#5406

Vendredi 27 Décervelage 139 (Saints Chemins de fer, assassins - fête Suprême Quarte)
4 Pluviôse An CCXX, 9,6168h - perce-neige
2012-W04-2T23:04:49Z

 

[BOISGONTIER]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour,

Respecte l'ordre initial (0,26 s)

Suppression rapide de lignes

Sub supLignesRapide()
  Application.ScreenUpdating = False
  Columns("b:b").Insert Shift:=xlToRight
  Range("B1:B" & [C65000].End(xlUp).Row).FormulaR1C1 = "=IF(RC[+2]="""",""sup"",0)"
  [B:B].Value = [B:B].Value
  [B1].CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

Autre méthode (0,15 sec )

Sub supLignesRapide2()
  Application.ScreenUpdating = False
  a = Range("C1:C" & [B65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
     If a(i, 1) <> "" Then a(i, 1) = 0 Else a(i, 1) = "Sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B1].Resize(UBound(a)) = a
  [B1].CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B1:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

JB

 

[flint6593]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Et le vainqueur est BOISGONTIER !!!!! C'est juste ENORME!!!!!

Merci à tous en tous cas!!!!!!

 

[pascal21]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

bonjour à tous

Et le vainqueur est BOISGONTIER !!!!!

comme d'hab.
toujours aussi court mais compensée par de l'efficacité

 

[MJ13]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour à tous

Attention, avec Excel, tout est relatif .

Voir fichier joint (copiez le fichier sur votre DD) .

 

[ROGER2327]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour à tous

Une autre version:

Sub mef1()
Dim x As Range
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135
        With Sheets("Feuil2").Columns("B")
            Set x = .Cells(1, 1).Offset(Rows.Count - 1, 0)
            .Insert Shift:=xlToRight
            .Resize(x.End(xlUp).Row, 1).Offset(0, -1).FormulaR1C1 = "=ISBLANK(RC[2])"
            .Resize(, 3).Offset(0, -1).Sort Key1:=.Offset(0, -1), Order1:=1, Header:=2, OrderCustom:=1, MatchCase:=0, Orientation:=1
            .Offset(0, -1).Delete Shift:=xlToLeft
            .Range(x.Offset(0, 1).End(xlUp), x.End(xlUp)).Offset(1, 0).EntireRow.Delete
        End With
        .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1
    End With
End Sub

- ne plante pas si exécutée sur une plage déjà traitée ;
- conserve l'ordre initial ;
- mais moins rapide que la précédente proposition.​

ROGER2327
#5409

Dimanche 1er Gueules 139 (Dépucelage de Mère Ubu - fête Suprême Tierce)
6 Pluviôse An CCXX, 0,9592h - laurier-tin
2012-W04-4T02:18:07Z

 

[MJ13]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour à tous

Merci Roger pour cette nouvelle version. C'est vrai que c'est plus long. On double le temps d'exécution de 0,15 secondes à 0,31 secondes pour environ 31000 lignes .

J'ai mis à jour le fichier .

PS: Attention sur XL2007, la procédure mef1 ne va pas, j'ai mis mefR1 car il ne faut pas mettre un nom qui peut faire référence à une adresse de cellule allant de A à XFD .

 

[ROGER2327]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour à tous,

Bonjour à tous

Merci Roger pour cette nouvelle version. C'est vrai que c'est plus long. On double le temps d'exécution de 0,15 secondes à 0,31 secondes pour environ 31000 lignes .

J'ai mis à jour le fichier .

PS: Attention sur XL2007, la procédure mef1 ne va pas, j'ai mis mefR1 car il ne faut pas mettre un nom qui peut faire référence à une adresse de cellule allant de A à XFD .

Merci à MJ13 pour le suivi des travaux. Je tiendrai compte de la remarque pour éviter l'inconvénient de la régression d'Excel2007. Compatibilité ascendante au sens de Bill...

Voici une autre version qui semble devoir donner satisfaction sur des séries de 500_000 lignes et plus. (Autour de 7 s pour un million de lignes sur ma machine avec Excel2010.)

Sub MefC()
Dim i&, x As Range
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135
        With Feuil2.Columns("B")
            Set x = .Cells(1, 1).Offset(Rows.Count - .Cells(1, 1).Row, 0)
            ReDim a&(1 To x.End(-4162).Row, 1 To 1)
            For i = 1 To UBound(a, 1): a(i, 1) = i: Next
            .Insert Shift:=-4161
            .Resize(x.End(-4162).Row, 1).Offset(0, -1).Value = a
            .Resize(, 3).Offset(0, -1).Sort Key1:=.Offset(0, 1), Order1:=1, Header:=2, OrderCustom:=1, MatchCase:=0, Orientation:=1
            .Range(x.Offset(0, 1).End(-4162), x.End(-4162)).Offset(1, 0).EntireRow.Delete
            .Resize(, 3).Offset(0, -1).Sort Key1:=.Offset(0, -1), Order1:=1, Header:=2, OrderCustom:=1, MatchCase:=0, Orientation:=1
            .Offset(0, -1).Delete Shift:=-4159
        End With
        .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1
    End With
End Sub

À suivre si j'en ai le temps : un classeur d'essai...​

ROGER2327
#5411

Mardi 3 Gueules 139 (Saint Anthropoïde, policier - fête Suprême Quarte)
8 Pluviôse An CCXX, 6,0688h - mézéréon
2012-W04-6T14:33:55Z

 

[MJ13]

Re : Aide pour gagner du temps execution macro 40 000 lignes?

Bonjour à tous

Merci à Roger pour cette nouvelle version .

Je met à jour le fichier. Avec tous ça, on a de quoi faire .