macro bien trop lente...structure grossière

Yldie · 18 Août 2018

Bonjour à toutes et à tous,

Comme dit en objet, j'ai réalisé avec mes petits moyens une macro qui fonctionne trop lentement sans doute par le fait que sa structure est une USINE à GAZ et comme je sais que certains ont l'art et la manière de simplifier via des méthodes ad hoc, je vous saurais gré de bien vouloir m'aider à gagner de précieuses secondes...pour ne pas dire minutes. Je sais beaucoup de redondances dans ma structure. Merci par avance.
Voici ma macro qui rame….rame...rame :
Sub etap1()
Dim Cell As Range
Application.Run "Test_Class_Ouvert"
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("pswd")
Range("Z8:AC14").Select
Selection.Copy
Range("C8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Locked = False
For Each Cell In Sheets("GRH").Range("C8:F14")
If Cell.Value = 0 Then
Cell.ClearContents
End If
Next Cell
Range("Z24:AC30").Select
Selection.Copy
Range("C24").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
For Each Cell In Sheets("GRH").Range("C24:F30")
If Cell.Value = 0 Then
Cell.ClearContents
End If
Next Cell
Selection.Locked = False
Range("Z40:AC46").Select
Selection.Copy
Range("C40").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Locked = False
For Each Cell In Sheets("GRH").Range("C40:F46")
If Cell.Value = 0 Then
Cell.ClearContents
End If
Next Cell
Range("Z56:AC62").Select
Selection.Copy
Range("C56").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Locked = False
For Each Cell In Sheets("GRH").Range("C56:F62")
If Cell.Value = 0 Then
Cell.ClearContents
End If
Next Cell
Range("Z72:AC78").Select
Selection.Copy
Range("C72").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Locked = False
For Each Cell In Sheets("GRH").Range("C72:F78")
If Cell.Value = 0 Then
Cell.ClearContents
End If
Next Cell
ActiveSheet.Protect ("pswd")
End Sub

Lone-wolf · 19 Août 2018

Bonjour Yldie, le Forum

@Yldie Il faudrait spécifier quelle version d'Excel que tu as et si tu travail avec MAC ou PC dans ton profil.

Note: le code est à adapter. Si la feuille active est autre que Sheets("GRH"), il faut l'ajouter après Copy. Exemple

Activesheet.Range("Z8:AC14").Copy Sheets("GRH").Range("C8")

Activesheet.Range("Z8:AC14").Copy
Sheets("GRH").Range("C8").PasteSpecial Paste:=xlPasteValues

Si il n'y a aucune mise en forme

VB:

With ActiveSheet
        .Range("Z8:AC14").Copy .Range("C8")
        .Range("Z24:AC30").Copy .Range("C24")
        .Range("Z40:AC46").Copy .Range("C40")
        .Range("Z56:AC62").Copy .Range("C56")
        .Range("Z72:AC78").Copy .Range("C72")
    End With

Sinon

VB:

Sub etap1()
Dim plage As Range, cel As Range

    Application.ScreenUpdating = False

    Call Test_Class_Ouvert
    ActiveSheet.Unprotect ("pswd")

    With ActiveSheet
        .Range("Z8:AC14").Copy
        .Range("C8").PasteSpecial Paste:=xlPasteValues
        .Range("Z24:AC30").Copy
        .Range("C24").PasteSpecial Paste:=xlPasteValues
        .Range("Z40:AC46").Copy
        .Range("C40").PasteSpecial Paste:=xlPasteValues
        .Range("Z56:AC62").Copy
        .Range("C56").PasteSpecial Paste:=xlPasteValues
        .Range("Z72:AC78").Copy
        .Range("C72").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = 0
    Application.goto Activesheet.Range("a1")

    With Sheets("GRH")
        Set plage = Union(.Range("C8:F14"), .Range("C24:F30"), _
        .Range("C40:F46"), .Range("C56:F62"), .Range("C72:F78"))

        For Each cel In plage
            If cel.Value = 0 Then cel.ClearContents
        Next cel
    End With

    ActiveSheet.Protect ("pswd")
End Sub

Yldie · 19 Août 2018

Bonjour Lone Wolf, le forum,

J'essaye ça mais si j'ai de réelles difficultés à "parler" en Vba, j'ai l'impression que je sais le "lire", ton code m'a l'air TOP pour ce que je veux....

Je te tiens au courant. Encore merci de t'être penché sur ce code "on ne peut plus maladroit"

Yldie · 19 Août 2018

Bonjour Lone Wolf, le forum,
3 min. 20 secondes...je me demande quand même si plutôt que d'effacer les "zéros" (For Each Cel In Range…..ClearContents…), je ne ferais pas mieux de laisser les "zéros" en les "teintant" (Tint >> couleur de police) à l'identique de la mise en forme de DESTINATION ?
Bref des "zéros" caméléon qui prendraient les couleurs de la mise en forme de destination, est-ce possible ????
Encore merci, peut être cela me fera-t-il gagner quelques minutes !?!?
A vous lire

Lone-wolf · 19 Août 2018

Re

EDIT: change la boucle For each par ceci

VB:

With Sheets("GRH")
        Set plage = .Range("C8:F14, C24:F30, C40:F46, C56:F62, C72:F78")

        For Each cel In plage
            If cel.Value = 0 Then cel.ClearContents
        Next cel
    End With

Pas besoin de Union.

EDIT2: non, c'est la mise en forme qui cause problème. Pour test, fait une copie du classeur en le renommant, enlève toutes les mises en forme et au lieu de Copy Paste, fait comme ceci:

VB:

With ActiveSheet
        .Range("Z8:AC14").Copy .Range("C8")
        .Range("Z24:AC30").Copy .Range("C24")
        .Range("Z40:AC46").Copy .Range("C40")
        .Range("Z56:AC62").Copy .Range("C56")
        .Range("Z72:AC78").Copy .Range("C72")
    End With

With Sheets("GRH")
        Set plage = .Range("C8:F14, C24:F30, C40:F46, C56:F62, C72:F78")

        For Each cel In plage
            If cel.Value = 0 Then cel.ClearContents
        Next cel
End With

Dranreb · 19 Août 2018

Bonjour.
Et en décochant cette option d'affichage ?
Ou encore en mettant ce format de nombre :

Code:

Standard;Standard;;

job75 · 19 Août 2018

Bonjour Yldie, Lone-wolf, Bernard,

Yldie à dit:
3 min. 20 secondes...je me demande quand même si plutôt que d'effacer les "zéros" (For Each Cel In Range…..ClearContents…), je ne ferais pas mieux de laisser les "zéros" en les "teintant"

Cette durée est incroyable ! Il n'y a que 140 cellules traitées c'est absolument peanuts !!!

Il y a autre chose : sans doute des formules qui se recalculent et qui prennent du temps.

Essayez ceci :

Code:

Sub etap2()
Dim deb1 As Range, deb2 As Range, nlig&, ncol%, pas&, i&
Set deb1 = [C8]: Set deb2 = [Z8]
nlig = 7: ncol = 4 'dimensions des tableaux
pas = 16
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'calcul manuel pour éviter le recalcul des formules
With ActiveSheet
    .Unprotect "pswd"
    For i = 1 To 5 '5 copies
        With deb1.Offset(pas * i - pas).Resize(nlig, ncol)
            .Value = deb2.Offset(pas * i - pas).Resize(nlig, ncol).Value 'copie les valeurs
            .Replace 0, "", xlWhole 'efface les valeurs zéro
        End With
    Next
    .Protect "pswd"
End With
Application.Calculation = xlCalculationAutomatic 'calcul automatic
End Sub

J'efface les valeurs zéro, ça ne devrait pas augmenter de beaucoup la durée.

A+

Yldie · 19 Août 2018

Bonjour Lone Wolf, Dranreb et Job75,

Tout d'abord bravo pour vos compétences respectives, j'ai appris bien des choses en peu de temps et vos connaissances sont monstrueuses..
En termes de durée, il est vrai que ce que me propose Job75 me plaît bien….juste un détail :
à la ligne de code >> .Replace 0, "", xlWhole 'efface les valeurs zéro
En fait il ne se passe rien, est-ce parce que ma cellule renvoi 0:00 (ici format heure)
Ce sera parfait si je peux effacer tous ces "zéros" ou 0:00

Encore un grand merci à vous pour vos contributions à des amateurs comme nous

Yldie · 19 Août 2018

Dranreb à dit:
Bonjour.
Et en décochant cette option d'affichage ?Regarde la pièce jointe 1016906
Ou encore en mettant ce format de nombre :

Code:

Standard;Standard;;

Bonjour Dranreb,

En fait j'ai pas compris où mettre le code text (??), je te cite :
<<Ou encore en mettant ce format de nombre :
Code (Text):
Standard;Standard;; >>
Merci d'avance pour tes lumières

job75 · 19 Août 2018

Re,

Il faudrait nous dire si Application.Calculation = xlCalculationManual raccourcit la durée ou pas, c'est ça qui importe.

Maintenant pour pouvoir effacer les heures nulles voici une petite gymnastique :

Code:

Sub etap2()
Dim deb1 As Range, deb2 As Range, nlig&, ncol%, pas&, i&
Set deb1 = [C8]: Set deb2 = [Z8]
nlig = 7: ncol = 4 'dimensions des tableaux
pas = 16
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'calcul manuel pour éviter le recalcul des formules
With ActiveSheet
    .Unprotect "pswd"
    For i = 1 To 5 '5 copies
        With deb1.Offset(pas * i - pas).Resize(nlig, ncol)
            .Value = deb2.Offset(pas * i - pas).Resize(nlig, ncol).Value 'copie les valeurs
            .NumberFormat = "General" 'format Standard
            .Replace 0, "", xlWhole 'efface les valeurs zéro
            .NumberFormat = "h:mm" 'format heure
        End With
    Next
    .Protect "pswd"
End With
Application.Calculation = xlCalculationAutomatic 'calcul automatique
End Sub

A+

job75 · 19 Août 2018

Re,

Bien sûr s'il s'agit de durées pouvant dépasser 24:00 utiliser :

Code:

 .NumberFormat = "[h]:mm" 'format heure

A+

Yldie · 19 Août 2018

Bonjour Lone Wolf, Dranreb et Job75,

Après quelques recherches, essais et autres bidouillages j'ai fait un mix entre les codes de Job75 et Lone Wolf…

En fait c'était bien un pb de formules qui se recalculaient et qui prenaient du temps (Application.Calculation = xlCalculationManual 'calcul manuel pour éviter le recalcul des formules - merci Job75)
Comme .Replace 0, " ", xlWhole ne fonctionnait pas j'ai mis à la place le code de Lone Wolf ;-)
With Sheets("GRH")
Set plage = .Range("C8:F14, C24:F30, C40:F46, C56:F62, C72:F78")

For Each cel In plage
If cel.Value = 0 Then cel.ClearContents
Next cel
End With

Je passe du coup de 3 min. 20 secondes à 3 secondes 25.....Elle est pas belle la vie !?!?

Encore un grand merci : RESOLU

Lone-wolf · 19 Août 2018

Re Yldie
Bonjour Gerard, Dranreb

@job75: bien vu pour les formules, j'y aurait jamais pensé. Merci pour ton intervention.

job75 · 19 Août 2018

Re,

Non pas encore RESOLU, si ma solution du post #10 pour effacer les zéros ne vous convient pas utilisez :

Code:

Sub etap2()
Dim deb1 As Range, deb2 As Range, nlig&, ncol%, pas&, n&, t, i&, j%
Set deb1 = [C8]: Set deb2 = [Z8]
nlig = 7: ncol = 4 'dimensions des tableaux
pas = 16
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'calcul manuel pour éviter le recalcul des formules
ActiveSheet.Protect "pswd", UserInterfaceOnly:=True
For n = 0 To 4 '5 copies
    t = deb2.Offset(pas * n).Resize(nlig, ncol) 'tableau VBA, plus rapide
    For i = 1 To nlig
        For j = 1 To ncol
            If t(i, j) = 0 Then t(i, j) = "" 'remplace les valeurs zéro du tableau
    Next j, i
    deb1.Offset(pas * n).Resize(nlig, ncol) = t 'restitution
Next
Application.Calculation = xlCalculationAutomatic 'calcul automatique
End Sub

J'utilise un tableau VBA, c'est toujours plus rapide que de travailler sur les cellules.

Et pour la protection j'utilise UserInterfaceOnly:=True, renseignez-vous.

A+

Yldie · 19 Août 2018

Re,

Job75 décidément c'est exhaustif, scrupuleux et sans défaut.....
Vous m'avez été d'une aide précieuse....encore merci

macro bien trop lente...structure grossière

Yldie

XLDnaute Junior

Lone-wolf

XLDnaute Barbatruc

Yldie

XLDnaute Junior

Yldie

XLDnaute Junior

Lone-wolf

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Yldie

XLDnaute Junior

Yldie

XLDnaute Junior

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Yldie

XLDnaute Junior

Lone-wolf

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Yldie

XLDnaute Junior

Discussions similaires