Code VBA à alléger

Question

J'ai une créer un code sur VBA qui me permet de modifier la couleur d'une plage de cellule en fonction d'une table de donnée selon le texte et la couleur de la table associée, a macro fonctionne mais met très longtemps à s'exécuter, peut être que l'un d'entre vous saurais comment alléger cette formule ? La formule fait référence a environ 1200 cellules, qui sont checkées une par une. D'avance merci pour votre aide, Julien Ci dessous le code Set F1 = Worksheets("Planning") With F1 Set Plage = .Range("H17:CQ71") End With For Z = 3 To 50 Step 1 For Each cell In Plage cell.Select If cell.Value = Cells(Z, 2).Value Then Selection.Interior.Color = F1.Cells(Z, 2).Interior.Color If cell.Value = Cells(Z, 2).Value Then Selection.Font.Color = F1.Cells(Z, 2).Font.Color Next Next Z...

Valky68 · Answer

Tu devrais utiliser des MFC (mises en forme conditionnelles) qui me semblent plus adaptées dans ton cas. Tu n'aurais alors plus besoin de macro...

Bizarre · Answer

Le délais indu est occasionné par .Select. Sélectionner les cellules ralentit énormément l'exécution du code. Modifié via ChatGPT : Private Sub EcritPlanning() Dim wsPlanning As Worksheet Dim cell As Range Dim dataRange As Range Dim searchRange As Range Dim searchValue As Variant Dim colorIndex As Long Dim fontColorIndex As Long Dim i As Long Set wsPlanning = Worksheets("Planning") Set searchRange = wsPlanning.Range("H17:CQ71") For i = 3 To 50 searchValue = wsPlanning.Cells(i, 2).Value colorIndex = wsPlanning.Cells(i, 2).Interior.Color fontColorIndex = wsPlanning.Cells(i, 2).Font.Color For Each cell In searchRange If cell.Value = searchValue Then cell.Interior.Color = colorIndex cell.Font.Color = fontColorIndex End If Next cell Next i End Sub Bizz...

saboh12617 · Answer

Plusieurs optimisations sont possibles, comme l'a soulevé Bizzarre le select est a éviter. De meme la lecture répétée des valeurs dans Excel, les types non déclarés, les .Value au lieu de .Value2 etc. Il y a beaucoup de possibilités. Cependant un fichier d'exemple serait apprécié, notamment pour tester les solutions. Ci-après une proposition, mais probablement a ajuster faute de test Sub a() Application.ScreenUpdating = False Dim F1 As Worksheet Set F1 = Worksheets("Planning") Dim plage As Range Set plage = F1.Range("H17:CQ71") Dim plageValues As Variant plageValues = plage.Value2 Dim plageCheck As Range With F1 plageCheck = .Range(.Cells(3, 2), .Cells(50, 2)) End With Dim plageCheckVals As Variant plageCheckVals = plageCheck.Value2 Dim rowI As Long, colI As Long, checkI As Long For rowI = LBound(plageValues, 1) To UBound(plageValues, 1) For colI = LBound(plageValues, 2) To UBound(plageValues, 2) For checkI = 3 To 50 If plageValues(rowI, colI) = plageCheckVals(checkI) Then With plage(rowI, colI) .Interior.color = plageCheck(checkI, 1).Interior.color .Font.color = plageCheck(checkI, 1).Font.color End With End If Next checkI Next colI Next rowI ' For z = 3 To 50 ' For Each cell In plage ' cell.Select ' If cell.Value2 = F1.Cells(z, 2).Value2 Then ' cell.Interior.color = F1.Cells(z, 2).Interior.color ' End If ' If cell.Value2 = Cells(z, 2).Value2 Then ' cell.Font.color = F1.Cells(z, 2).Font.color ' End If ' Next cell ' Next z Application.ScreenUpdating = True End Sub...

galopin01 · Answer

La Cells(Z, 2) est dans quelle feuille ? La feuille planning également ? Edit: Supprimé question stupide...Les macros sont étroitement tributaires du classeur et des feuilles concernées. Il est très difficile d'évaluer la pertinence de nos réponses : Une bonne habitude à prendre : A+...

galopin01 · Answer

Sans mot de passe c'est pas très utile ...

saboh12617 · Answer

Je vous propose ce Sub, qui skip les cellules vides évitant ainsi de parcourir toutes la seconde plage pour y trouver une correspondance.

Je vous laisse le tester car je ne sais pas comment modifier votre fichier ni les résultats attendus. Cependant le sub est théoriquement fonctionnel.

Sub Couleur2()

  Application.ScreenUpdating = False

  Dim F1 As Worksheet
  Set F1 = Worksheets("Planning")

  Dim plage As Range
  Set plage = F1.Range("H17:CQ71")
  Dim plageValues As Variant
  plageValues = plage.Value2

  Dim plageCheck As Range
  With F1
    Set plageCheck = .Range(.Cells(3, 2), .Cells(50, 2))
  End With
  Dim plageCheckVals As Variant
  plageCheckVals = plageCheck.Value2

  Dim rowI As Long, colI As Long, checkI As Long

  For rowI = LBound(plageValues, 1) To UBound(plageValues, 1)
    For colI = LBound(plageValues, 2) To UBound(plageValues, 2)
      If plageValues(rowI, colI) <> vbNullString Then
        For checkI = LBound(plageCheckVals, 1) To UBound(plageCheckVals, 1)
          If plageValues(rowI, colI) = plageCheckVals(checkI, 1) Then
            With plage(rowI, colI)
              .Interior.Color = plageCheck(checkI, 1).Interior.Color
              .Font.Color = plageCheck(checkI, 1).Font.Color
            End With
          End If
        Next checkI
      End If
    Next colI
  Next rowI

  Application.ScreenUpdating = True
End Sub

galopin01 · Answer

Bon j'ai trouvé mais même avec mot de passe comme il n'y a aucune donnée ce n'est pas exploitable...

Une tite macro qui me semble pas trop mal au point :

Sub Galopin()
Dim ARef, ArrC, iR%, kR%, kC%
Application.ScreenUpdating = False
With Worksheets("Planning")
ARef = .Range("B3:D50").Value
ArrC = .Range("H17:CQ71").Value
For iR = 1 To 48
   ARef(iR, 2) = .Cells(iR + 2, 2).Interior.Color
   ARef(iR, 3) = .Cells(iR + 2, 2).Font.Color
Next
For iR = 1 To 48
   For kR = 1 To UBound(ArrC)
      For kC = 1 To UBound(ArrC, 2)
         If ArrC(kR, kC) = ARef(iR, 1) Then
            .Cells(kR + 16, kC + 7).Interior.Color = ARef(iR, 2)
            .Cells(kR + 16, kC + 7).Font.Color = ARef(iR, 3)
         End If
      Next
   Next
Next
End With
End Sub

A+

Valky68 · Answer

Bonjour à tous,
Je propose des petites modifications de la macro d’origine qui ont un gros effet a priori :

Sub Couleur()
    '
    ' Couleur Macro
    '
    Application.ScreenUpdating = FALSE

    Sheets("Postes").Select
    Range("C8:C49").Copy

    Sheets("Planning").Select
    Cells.EntireColumn.Hidden = FALSE ' modifié
    Cells.EntireRow.Hidden = FALSE' modifié

    Range("B3").PasteSpecial (xlPasteAll)' modifié
    Columns("A:B").EntireColumn.Hidden = TRUE
    Rows("1:5").EntireRow.Hidden = TRUE

    Dim wsPlanning  As Worksheet
    Dim cell        As Range
    Dim dataRange   As Range
    Dim searchRange As Range
    Dim searchValue As Variant
    Dim colorIndex  As Long
    Dim fontColorIndex As Long
    Dim i           As Long

    Set wsPlanning = Worksheets("Planning")
    Set searchRange = wsPlanning.Range("H17:CQ71").SpecialCells(xlCellTypeFormulas, 23) ' modifié (ne prend en compte que les cellules qui ont une formule, il y en a 4 fois moins !)

    For i = 3 To 50
        If wsPlanning.Cells(i, 2) <> "" Then ' Ajouté. Inutile de balayer 48 valeurs s’il n’y en a que quelques-unes qui sont définies.
            searchValue = wsPlanning.Cells(i, 2).Value
            colorIndex = wsPlanning.Cells(i, 2).Interior.Color
            fontColorIndex = wsPlanning.Cells(i, 2).Font.Color

            For Each cell In searchRange
                If cell.Value = searchValue Then
                    cell.Interior.Color = colorIndex
                    cell.Font.Color = fontColorIndex
                End If
            Next cell
        End If ' Ajouté
    Next i

    Application.ScreenUpdating = TRUE

End Sub

galopin01 · Answer

Testé avec une plage entièrement complète et un screenupdating la macro est instantanée. a+...

saboh12617 · Answer

Merci pour le fichier test Galopin! (apparemment ma macro est 1e-5 s plus rapide hehe @.@) (comment as tu généré le fichier ?)

Moeisson si ton problème est résolu, tu peux le marquer en tant que tel.