XL 2013 mise en surbrillance sous condition

ANTONY34200 · 15 Février 2023

Bonjour le forum,
j'ai besoin d'une petite formule afin de me permettre de mettre en surbrillance une selection de cellule comprise dans une colonne.

je m'explique.

dans la plage H5 à H35, si j'ai plus de 5 cellules non vide consécutive, j'aimerais pouvoir les mettre en surbrillance. sois par VBA soit par MFC.

Dans l'attente d'un petit coup de pouce, je vous remerci d'avance.

fanch55 · 15 Février 2023

Bonjour
Fonction à mettre dans un module et à appeler via MFC :

VB:

Function NbCons(Cell As Range)
Dim I As Integer
Dim N As Integer: N = 1
Dim M As Integer: M = 4 ' Nombre mini de cellules consécutives

    If Cell <> "" Then
        For I = 1 To M
            If Cell.Offset(I) = "" Then Exit For
            N = N + 1
        Next
        For I = 1 To M
            If Cell.Offset(-I) = "" Then Exit For
            N = N + 1
        Next
    End If
    
NbCons = N > M
End Function

La fonction ci-dessous contrôle si 5 cellules consécutives ont la même valeur :

VB:

Function NbConsIdem(Cell As Range)
Dim I As Integer
Dim N As Integer: N = 1
Dim M As Integer: M = 4 ' Nombre mini de cellules consécutives

    If Cell <>...

sylvanu · 15 Février 2023

Bonjour Anthony, le forum,
Un essai en PJ avec :

VB:

Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fin: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H1:H1000")) Is Nothing Then
         Application.ScreenUpdating = False
         [H:H].Interior.Color = xlNone
         PL = [E1].End(xlDown).Row
         DL = [E65500].End(xlUp).Row
            For L = PL To DL
                Début = L: Fin = L
                While Cells(Fin, "H") <> ""
                    Fin = Fin + 1
                Wend
                If Fin - Début >= 5 Then
                    Range(Cells(Début, "H"), Cells(Fin - 1, "H")).Interior.Color = RGB(255, 255, 0)
                    L = L + Fin - Début
                    If L > DL Then Exit Sub
                End If
            Next L
    End If
Fin:
Application.ScreenUpdating = True
End Sub

ANTONY34200 · 15 Février 2023

Sylvanu,
merci pour le retour.
je dois adapter le code à ma vrai feuille de calcul. a quoi corespond le L ??

sylvanu · 15 Février 2023

Re,
C'est l'indice du For :

VB:

For L = PL To DL

De PL première ligne à DL dernière ligne.

fanch55 · 15 Février 2023

Bonjour
Fonction à mettre dans un module et à appeler via MFC :

VB:

Function NbCons(Cell As Range)
Dim I As Integer
Dim N As Integer: N = 1
Dim M As Integer: M = 4 ' Nombre mini de cellules consécutives

    If Cell <> "" Then
        For I = 1 To M
            If Cell.Offset(I) = "" Then Exit For
            N = N + 1
        Next
        For I = 1 To M
            If Cell.Offset(-I) = "" Then Exit For
            N = N + 1
        Next
    End If
    
NbCons = N > M
End Function

La fonction ci-dessous contrôle si 5 cellules consécutives ont la même valeur :

VB:

Function NbConsIdem(Cell As Range)
Dim I As Integer
Dim N As Integer: N = 1
Dim M As Integer: M = 4 ' Nombre mini de cellules consécutives

    If Cell <> "" Then
        For I = 1 To M
            If Cell.Offset(I) <> Cell Then Exit For
            N = N + 1
        Next
        For I = 1 To M
            If Cell.Offset(-I) <> Cell Then Exit For
            N = N + 1
        Next
    End If
    
NbConsIdem = N > M
End Function

ANTONY34200 · 15 Février 2023

Ok,
quand je copie le code dans mon fichier, j'ai un débogage ...

ANTONY34200 · 15 Février 2023

FANCH55,
merci du retour, je viens de tester, ça fonctionne nickel.
Merci

job75 · 15 Février 2023

Bonjour ANTONY34200, le fil,

Pas besoin de VBA, voyez le fichier joint avec cette MFC sur H5:H35 :

Code:

=OU(NBVAL(DECALER(H5;;;5))=5;NBVAL(DECALER(H5;-1;;5))=5;NBVAL(DECALER(H5;-2;;5))=5;NBVAL(DECALER(H5;-3;;5))=5;NBVAL(DECALER(H5;-4;;5))=5)

A+

ANTONY34200 · 16 Février 2023

Bonjour job75,
merci pour cette solution, jela garde sous le coude, et je pense devoir m'en servir pour un autre soucis dont vous venez certaiment de m'apporter la solution ...

XL 2013 mise en surbrillance sous condition

ANTONY34200

XLDnaute Occasionnel

Pièces jointes

fanch55

sylvanu

XLDnaute Barbatruc

Pièces jointes

ANTONY34200

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

ANTONY34200

XLDnaute Occasionnel

ANTONY34200

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

ANTONY34200

XLDnaute Occasionnel

Discussions similaires