XL 2019 Macro d'activation de mise en forme conditionnelle "glissante"

[Flomax]

Bonjour,

J'ai développé un fichier pour gérer les compétences et polyvalences qui plait bien et qui est visuel, mais malheureusement la mise en forme conditionnelle ralenti énormément sa mise à jour.

N'étant pas expert en macro (je sais juste changer des paramètres dedans, ou une ou deux bidouilles) :

- sauriez-vous faire une macro de mise en forme conditionnelle qui reprend celle créée manuellement ci-dessous ? :

ET((SI(NB.SI('BDD Fiches de formation'!$E:$E;CONCAT(F$1;$A6))>0;1;0)+SI(NB.SI('BDD Fiches de formation'!$E:$E;CONCAT(F$2;$A6))>0;1;0)+SI(NB.SI('BDD Fiches de formation'!$E:$E;CONCAT(F$3;$A6))>0;1;0)+SI(NB.SI('BDD Fiches de formation'!$E:$E;CONCAT(F$4;$A6))>0;1;0))<NBVAL(#REF!);F6<>"")

Cette mise en forme est appliquée de la case F6 à I9, créée sur la case F6 puis étendue sur les autres, donc la colonne analysée pour la MFC évolue selon la colonne de la case concernée.

J'ai cherché sur internet mais je n'ai pas trouvé d'exemple que je pourrais reporter sur mon cas.

J'ai mis en pièce jointe une version "générique" du fichier d'origine. L'originale contient beaucoup plus de colonnes et de lignes (de L5 à PV79 actuellement), qui fait qu'après une saisie de case on attend 10 à 20s pour que le calcule se fasse, ce qui n'est pas le cas dans cette version.

Au plaisir de vous entendre,

Flomax

 

[Gégé-45550]

Bonjour,
OUPS, voilà ce que c'est que de travailler tard le soir, on réfléchit de travers et on mélange les indices !
Cette Sub devrait mieux marcher :

Sub Coloriage()
Dim objCollabos As Object, Col1 As Range, ChampCible As Range, NbLignes As Long, NbColonnes As Long, i%, j%, wkCollabos As Worksheet, wkProd As Worksheet, Combo1$, Combo2$, Combo3$, Combo4$
    Set wkCollabos = ThisWorkbook.Worksheets("BDD Fiches de Formation")
    Set objCollabos = wkCollabos.ListObjects("_Collaborateurs")
    Set wkProd = ThisWorkbook.Worksheets("MdP Prod")
    Set Col1 = objCollabos.ListColumns("Colonne1").DataBodyRange
    Set ChampCible = wkProd.Range("PolyProd[[Colonne2]:[a415]]")        '$N$14:$PM$79 - si des colonnes sont ajoutées APRÈS la colonne PM, remplacer la dernière valeur entre crochets (ici a415) par le nouveau nom de la dernière colonne
    NbLignes = ChampCible.Rows.Count
    NbColonnes = ChampCible.Columns.Count
    Application.ScreenUpdating = False
    usfInfo.Afficher
    For i = 1 To NbLignes
        usfInfo.Actualiser CInt((i / NbLignes) * 100)
        For j = 1 To NbColonnes
            Combo1 = wkProd.Cells(5, j + 13) & wkProd.Cells(i + 13, 1)
            Combo2 = wkProd.Cells(6, j + 13) & wkProd.Cells(i + 13, 1)
            Combo3 = wkProd.Cells(7, j + 13) & wkProd.Cells(i + 13, 1)
            Combo4 = wkProd.Cells(8, j + 13) & wkProd.Cells(i + 13, 1)
            If ChampCible.Cells(i, j) <> "" And (Application.WorksheetFunction.CountIf(Col1, Combo1) + Application.WorksheetFunction.CountIf(Col1, Combo2) + Application.WorksheetFunction.CountIf(Col1, Combo3) + Application.WorksheetFunction.CountIf(Col1, Combo4)) > 0 Then
                With ChampCible(i, j).Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 13590431
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            Else
                ChampCible(i, j).Interior.ColorIndex = xlColorIndexNone
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
    Set wkCollabos = Nothing
    Set objCollabos = Nothing
    Set wkProd = Nothing
    Set Col1 = Nothing
    Set ChampCible = Nothing
End Sub

Cordialement

 

[Flomax]

Bonjour,

Avec un peu de délai, je reviens sur le sujet ! La mise en forme de Gégé était pas mal mais ça ne me surlignait pas les bonnes cases. Comme j'avais d'autres sujets plus prioritaires sur le sujet, je ne m'étais pas penché dessus, jusqu'à hier ! Du coup j'ai trouvé le problème, qui était sur la formule principale. Voici donc la version qui fonctionne impeccablement :

Sub Coloriage()
Dim objCollabos As Object, Col1 As Range, ChampCible As Range, NbLignes As Long, NbColonnes As Long, i%, j%, wkCollabos As Worksheet, wkProd As Worksheet, Combo1$, Combo2$, Combo3$, Combo4$
    Set wkCollabos = ThisWorkbook.Worksheets("BDD Fiches de Formation")
    Set objCollabos = wkCollabos.ListObjects("_Collaborateurs")
    Set wkProd = ThisWorkbook.Worksheets("MdP Prod")
    Set Col1 = objCollabos.ListColumns("Colonne1").DataBodyRange
    Set ChampCible = wkProd.Range("PolyProd[[Colonne2]:[a415]]")        '$N$14:$PM$79 - si des colonnes sont ajoutées APRÈS la colonne PM, remplacer la dernière valeur entre crochets (ici a415) par le nouveau nom de la dernière colonne
    NbLignes = ChampCible.Rows.Count
    NbColonnes = ChampCible.Columns.Count
    Application.ScreenUpdating = False
    usfInfo.Afficher
    For i = 1 To NbLignes
        usfInfo.Actualiser CInt((i / NbLignes) * 100)
        For j = 1 To NbColonnes
            Combo1 = wkProd.Cells(5, j + 13) & wkProd.Cells(i + 13, 1)
            Combo2 = wkProd.Cells(6, j + 13) & wkProd.Cells(i + 13, 1)
            Combo3 = wkProd.Cells(7, j + 13) & wkProd.Cells(i + 13, 1)
            Combo4 = wkProd.Cells(8, j + 13) & wkProd.Cells(i + 13, 1)
            If ChampCible.Cells(i, j) <> "" And (Application.WorksheetFunction.CountIf(Col1, Combo1) + Application.WorksheetFunction.CountIf(Col1, Combo2) + Application.WorksheetFunction.CountIf(Col1, Combo3) + Application.WorksheetFunction.CountIf(Col1, Combo4)) < Application.WorksheetFunction.CountA(wkProd.Cells(9, j + 13), wkProd.Cells(10, j + 13), wkProd.Cells(11, j + 13), wkProd.Cells(12, j + 13)) Then
                With ChampCible(i, j).Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 13590431
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            Else
                ChampCible(i, j).Interior.ColorIndex = xlColorIndexNone
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
    Set wkCollabos = Nothing
    Set objCollabos = Nothing
    Set wkProd = Nothing
    Set Col1 = Nothing
    Set ChampCible = Nothing
End Sub

Merci beaucoup pour votre aide, le fichier est maintenant au top !