macro bien trop lente...structure grossière

Yldie

XLDnaute Junior
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

XLDnaute Barbatruc
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
 
Dernière édition:

Yldie

XLDnaute Junior
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

XLDnaute Junior
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

XLDnaute Barbatruc
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
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Et en décochant cette option d'affichage ?
upload_2018-8-19_9-59-49.png

Ou encore en mettant ce format de nombre :
Code:
Standard;Standard;;
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Yldie, Lone-wolf, Bernard,
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

XLDnaute Junior
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
 

job75

XLDnaute Barbatruc
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+
 

Yldie

XLDnaute Junior
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
 

job75

XLDnaute Barbatruc
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+
 
Dernière édition:

Discussions similaires

Réponses
2
Affichages
80

Statistiques des forums

Discussions
311 720
Messages
2 081 917
Membres
101 839
dernier inscrit
laurentEstrées