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
Bonjour,
met ta couleur d'extrémités voulue en BF1 et :
ericVB: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
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
On Error Resume Next
Set pl = Cells(lig, 7).Resize(, 49).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0