coloriage (vba?)

[OlivGM]

Bonsoir,

Je voudrais colorier mon tableau tel que montré dans mon petit exemple joint.
Il y a environ 500 lignes pour info.

Merci et bonne soirée

 

[eriiic]

Bonjour,

met ta couleur d'extrémités voulue en BF1 et :

Sub colore()
    Dim pl As Range, pl2 As Range, lig As Long
    Dim nbMin As Long, coul1 As Long, coul2 As Long
    nbMin = [BE1]: coul1 = [BE1].Interior.Color: coul2 = [BF1].Interior.Color
    For lig = 2 To 379
        Set pl = Cells(lig, 7).Resize(, 49).SpecialCells(xlCellTypeBlanks)
        If Not pl Is Nothing Then
            For Each pl2 In pl.Areas
                If pl2.Count >= nbMin Then pl2.Interior.Color = coul1
                If pl2.Column = 7 Then pl2.Interior.Color = coul2
                If pl2.Column + pl2.Count - 1 = 55 Then pl2.Interior.Color = coul2
            Next pl2
        End If
    Next lig
End Sub

eric

 

[kingfadhel]

Bonjour,

met ta couleur d'extrémités voulue en BF1 et :

Sub colore()
    Dim pl As Range, pl2 As Range, lig As Long
    Dim nbMin As Long, coul1 As Long, coul2 As Long
    nbMin = [BE1]: coul1 = [BE1].Interior.Color: coul2 = [BF1].Interior.Color
    For lig = 2 To 379
        Set pl = Cells(lig, 7).Resize(, 49).SpecialCells(xlCellTypeBlanks)
        If Not pl Is Nothing Then
            For Each pl2 In pl.Areas
                If pl2.Count >= nbMin Then pl2.Interior.Color = coul1
                If pl2.Column = 7 Then pl2.Interior.Color = coul2
                If pl2.Column + pl2.Count - 1 = 55 Then pl2.Interior.Color = coul2
            Next pl2
        End If
    Next lig
End Sub

eric

Bonsoir,
Rien à dire, c'est excellent.

voilà ce que j'ai commencé à faire mais après avoir vu le code d' @eriiiic 😳😳😳😱😱😱

Sub Mise_en_forme()
For k = 4 To 4
    For l = 55 To 7 Step -1
        Var = 0
        If Not IsEmpty(Cells(k, l)) Then
        Var = Var + 1
        End If
        If Var <> 0 Then
        GoTo suite2
        End If
    Next l
suite2:
Range(Cells(k, 55), Cells(k, l + 1)).Interior.Color = RGB(197, 217, 241)
Next k
For j = 4 To 4
    For i = 7 To 55
        Var = 0
        If Not IsEmpty(Cells(j, i)) Then
        Var = Var + 1
        End If
        If Var <> 0 Then
        GoTo suite
        End If
    Next i
suite:
Range(Cells(j, 7), Cells(j, i - 1)).Interior.Color = RGB(197, 217, 241)
Next j
End Sub

code seulement pour les couleurs d'extrémités.😉😉

 

[eriiic]

;-)
j'avais démarré un peu comme toi avant d'avoir cette idée.

 

[OlivGM]

Bonjour,

Merci pour vos 2 macros:
Sur la macro d'Eric j'ai un bug ici: Set pl = Cells(lig, 7).Resize(, 49).SpecialCells(xlCellTypeBlanks)
et sur la macro de Kingfadhel le haut du tableau se colore mal? (voir fichier)

Merci

 

[eriiic]

Bonjour,

parce que tu n'as aucune cellule vide, il y a des espaces.
Ce n'est pas parce qu'on ne les voit pas qu'ils ne comptent pas.
Supprime tes espaces et remplace la ligne par :

        On Error Resume Next
        Set pl = Cells(lig, 7).Resize(, 49).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0

eric

 

[OlivGM]

Bonjour,

Est-il possible que la macro supprime les espaces?
Toutefois, chaque cellule est une formule SI....valeur, sinon "" donc est-il plutôt possible de modifier la macro en testant si c'est un caractère alphanumérique plutôt qu'une cellule vide?
Sinon je vais devoir reécrire la formule à chaque fois qu'elle aura été effacée.

Merci
Bon samedi.

 

[eriiic]

Bonjour,

une cellule avec une formule n'est pas une cellule vide.
Donc ma technique avec .SpecialCells(xlCellTypeBlanks) ne peut pas fonctionner dans ce cas.
Il faut donc balayer toutes les cellules comme le faisait kingfadhel.
eric