Optimisation de code sur visuel d'avancement de projet

[adinnn]

Bonjour à tous,

J'ai créé une macro qui sert à voir l'avancement d'un projet de facon visuel (colonne J - AC) sur 20 cellules en fonction du pourcentage entré en colonne G. Le problème est que le code prend trop de temps à exécuter. J'aimerais donc l'optimiser car je voudrais faire la validation sur 4000 lignes.

Voir fichier joint

Merci de votre aide

rivate Sub CommandButton1_Click()
Dim myrange As Range
Dim cell As Range
Dim count As Integer
Dim a As Integer


For a = 12 To 50
Set myrange = ActiveSheet.Range("J" & a & ":AC" & a)
count = 20 * Range("G" & a).Value

For Each cell In myrange

    If count > 0 Then
    'cell.Value = "x"
    With cell.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With cell.Interior.Gradient.ColorStops.Add(0)
        .Color = 15773696
        .TintAndShade = 0
    End With
    With cell.Interior.Gradient.ColorStops.Add(0.5)
        .Color = 65535
        .TintAndShade = 0
    End With
    With cell.Interior.Gradient.ColorStops.Add(1)
        .Color = 15773696
        .TintAndShade = 0
    End With
    
    count = count - 1
    Else
    'cell.Value = ""
    With cell.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With cell.Interior.Gradient.ColorStops.Add(0)
        .Color = 15773696
        .TintAndShade = 0
    End With
    With cell.Interior.Gradient.ColorStops.Add(0.5)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With cell.Interior.Gradient.ColorStops.Add(1)
        .Color = 15773696
        .TintAndShade = 0
    End With
    End If
Next cell

Next
End Sub

 

[jpb388]

Re : Optimisation de code sur visuel d'avancement de projet

Bonjour à tous
regarde si cela améliore le traitement

Private Sub CommandButton1_Click()
Dim myrange As Range
Dim cell As Range
Dim count As Integer
Dim a As Integer


For a = 12 To 50
Set myrange = ActiveSheet.Range("J" & a & ":AC" & a)
count = 20 * Range("G" & a).Value

For Each cell In myrange

    'cell.Value = "x"
    With cell.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With cell.Interior.Gradient.ColorStops.Add(0)
        .Color = 15773696
        .TintAndShade = 0
    End With
    With cell.Interior.Gradient.ColorStops.Add(0.5)
        If count > 0 Then .Color = 65535 Else .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With cell.Interior.Gradient.ColorStops.Add(1)
        .Color = 15773696
        .TintAndShade = 0
    End With
    
    count = count - 1
Next cell

Next
End Sub

 

[adinnn]

Re : Optimisation de code sur visuel d'avancement de projet

Bonjour jpb388,
le traitement est aussi long. En fait je crois que le temps de traitement ne vient pas du code pour les couleurs des cellules. J'ai tenté de le faire avec des X dans les cellules et c'est aussi long...

des idées?

 

[jpb388]

Re : Optimisation de code sur visuel d'avancement de projet

re
celle là devrait être plus rapide
si tu veux encore un peu accéléré tu décoches les 2 lignes screenupdapting

Private Sub CommandButton1_Click()
    Dim Pl As Range, Cel As Range, Lg&
'    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Range("J12:AC" & Rows.Count).Clear
    Lg = Range("A" & Rows.Count).Row
    Set Pl = Range("G12:G" & Lg)
    For Each Cel In Pl.Rows
        If Cel <> "" Then
            With Range("J" & Cel.Row & ":AC" & Cel.Row).Interior
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 90
            '    .Gradient.ColorStops.Clear
            End With
            With Range(Cells(Cel.Row, 10), Cells(Cel.Row, 9 + (Cel * 20))).Interior.Gradient.ColorStops
                .Add(0).Color = 15773696
                .Add(0.5).Color = 65535
                .Add(1).Color = 15773696
                .Add(0).TintAndShade = 0
            End With
        End If
    Next Cel
 '   Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

 

[Si...]

Re : Optimisation de code sur visuel d'avancement de projet

salut

autre exemple (une seule cellule de vision avec formule puis valeur)

Private Sub CommandButton1_Click()
  Dim Plage As Range
  Set Plage = ActiveSheet.Range("J12:J4200")
  Plage = "": Plage.Interior.Pattern = xlNone
  With Plage.Interior
    .Pattern = xlPatternLinearGradient
    .Gradient.Degree = 90
    .Gradient.ColorStops.Clear
    .Gradient.ColorStops.Add(0).Color = 15773696
    .Gradient.ColorStops.Add(0.5).Color = 65535
    .Gradient.ColorStops.Add(1).Color = 15773696
  End With
  Plage.FormulaR1C1 = "=IF(RC[-3]="""","""",REPT(""·"",RC[-3]*100))"
  Plage = Plage.Value
End Sub

On peut, pour une vision immédiate, le faire sans macro et en passant par une formule.

Maintenant si tu as beaucoup d'autres formules gourmandes , elles peuvent ralentir le déroulement des acions.

 

[adinnn]

Re : Optimisation de code sur visuel d'avancement de projet

Bonjour,

Merci à vous 2

@Jpb388: C'est effectivement plus rapide mais l'exécution prend encore 10 sec ce qui est trop long malheureusement.

@si... L'exécution du code est vraiment rapide, par contre le visuel manque un peu à mon avis. Est-ce possible au lieu de mettre des caractère d'y ajouter des couleurs avec dégradé comme dans mon projet initial?

Au plaisir!