XL 2016 Mettre en gras et souligné la date dans une macro

[Loic80]

Bonjour,

Sur ma macro je souhaite mettre les dates en gras et souligné dans la colonne "J". Pourriez-vous m'aider svp.
Merci.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Sh.Range("E1:E" & Sh.Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64))
With r.Font: .ColorIndex = xlAutomatic: .Bold = False: .Underline = xlNone: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
For i = 0 To UBound(texte)
j = InStr(r, texte(i))
If j Then
With r.Characters(j, Len(texte(i))).Font
.Color = couleur(i)
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
End If
Next i, r
End Sub

 

[fanch55]

Bonjour,

1. Pourquoi utiliser le Workbook_SheetChange, cela doit se faire pour toutes les feuilles ?
2. Je ne vois pas de référence à la colonne J dans ce code
3. Un exemple light de classeur serait le bienvenu

 

[Loic80]

Bonjour,

1. On m'avait fait utiliser le Workbook_SheetChange car j'avais 12 ongles sur le classeur mais je n'en ai plus qu'un seul.
2. J'ai modifié mon tableau entre temps donc j'ai modifié la colonne I en J.
3. Je vous joins une copie de mon fichier en mettant la date que je souhaite en gras et souligné.

Merci.

 

[fanch55]

Je ne vois pas plus de date dans le classeur joint

 

[Loic80]

Je viens de rajouter des dates. En fait je serai amené a ajouter des datrs dans mon tableau donc il n'y a pas forcément de dates précises. Je souhaite que lorsque je rentre une date celle ci soit e' gras et soulignée.
Merci.

 

[Phil69970]

Bonjour @Loic80 , @fanfan38

Je te propose :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Sh.Range("J1:J" & Sh.Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR", "RAS", "PAV VETUSTE !", "PAV A CHANGER !")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64), RGB(0, 0, 0), RGB(255, 0, 0), RGB(255, 0, 0))
With r.Font: .ColorIndex = xlAutomatic: .Bold = True: .Underline = xlUnderlineStyleSingle: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
    For i = 0 To UBound(texte)
        j = InStr(r, texte(i))
        If j Then
            With r.Characters(j, Len(texte(i))).Font
                .Color = couleur(i)
                .Bold = True
                .Underline = xlUnderlineStyleSingle
            End With
        End If
Next i, r

End Sub

@Phil69970

 

[Loic80]

Bonjour Phil69970,

J'ai essayé ta macro mais tout le texte se met en gras et souligné, or je souhaite que ce ne soit que la date qui le soit.

Merci.

 

[fanch55]

Bonjour,
Macro à tester .

Attention: Cet événement ( et donc le code associé ) est déclenché uniquement si les valeurs de cellules changent,
La modification seule des polices de toute une sélection reste donc permise, on ne peut pas l'interdire ( à ma connaissance ) .

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim R As Range
    Set R = Intersect(Target, Sh.Range("J1:J" & Sh.Rows.Count))
    If R Is Nothing Then Exit Sub

Dim Texte:        Texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR", "RAS", "PAV VETUSTE !", "PAV A CHANGER !")
Dim Couleur:    Couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64), RGB(0, 0, 0), RGB(255, 0, 0), RGB(255, 0, 0))
Dim Gras:          Gras = Array(False, False, False, False, False, False, False)
Dim Souligné:  Souligné = Array(False, False, False, False, False, False, False)
Dim W As Variant
Dim I As Integer
Dim J As Integer

    For Each R In R 'si entrées multiples (copier-coller)
        For I = 0 To UBound(Texte)
            J = InStr(R, Texte(I))
            If J Then
                With R.Characters(J, Len(Texte(I))).Font
                    .Color = Couleur(I)
                    .Bold = Gras(I)
                    .Underline = Souligné(I)
                End With
            End If
        Next
        ' On va traquer les dates ( il peut en avoir plusieurs dans la chaine )
        W = R
        For I = 1 To Len(R)
            If Not (Mid(R, I, 1) = "/" Or IsNumeric(Mid(R, I, 1))) Then Mid(W, I, 1) = " "
        Next
        While InStr(W, "  "): W = Replace(W, "  ", " "): Wend
        J = 0
        For Each W In Split(Replace(Trim(W), " ", vbLf), vbLf)
            If IsDate(W) Then
                J = InStr(J + 1, R, W)
                With R.Characters(J, Len(W)).Font
                    .Bold = True
                    .Underline = xlUnderlineStyleSingle
                End With
            End If
        Next
    Next

End Sub

 

[Loic80]

Bonjour fanch55,

Merci pour ton aide, je m'excuse de ne répondre que maintenant.
Ta macro fonctionne 🙂
Je l'ai juste modifié un petit peu mais les dates sont bien en gras.
Encore merci à tous pour votre soutien.

Cordialement,



Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim R As Range
Set R = Intersect(Target, Sh.Range("J1:J" & Sh.Rows.Count))
If R Is Nothing Then Exit Sub

Dim Texte: Texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR", "RAS", "PAV VETUSTE !", "PAV A CHANGER !", "Mise à jour du")
Dim Couleur: Couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64), RGB(0, 0, 0), RGB(255, 0, 0), RGB(255, 0, 0), RGB(0, 0, 0))
Dim Gras: Gras = Array(True, True, True, True, True, True, True, True)
Dim Souligné: Souligné = Array(True, True, True, True, True, True, True, True)
Dim I As Integer
Dim J As Integer

For Each R In R 'si entrées multiples (copier-coller)
For I = 0 To UBound(Texte)
J = InStr(R, Texte(I))
If J Then
With R.Characters(J, Len(Texte(I))).Font
.Color = Couleur(I)
.Bold = Gras(I)
.Underline = Souligné(I)
End With
End If
Next
' On va traquer les dates ( il peut en avoir plusieurs dans la chaine )
W = R
For I = 1 To Len(R)
If Not (Mid(R, I, 1) = "/" Or IsNumeric(Mid(R, I, 1))) Then Mid(W, I, 1) = " "
Next
While InStr(W, " "): W = Replace(W, " ", " "): Wend
J = 0
For Each W In Split(Replace(Trim(W), " ", vbLf), vbLf)
If IsDate(W) Then
J = InStr(J + 1, R, W)
With R.Characters(J, Len(W)).Font
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
End If
Next
Next

End Sub

 

[fanch55]

Je l'ai juste modifié un petit peu mais les dates sont bien en gras.

' On va traquer les dates ( il peut en avoir plusieurs dans la chaine )
W = R
For I = 1 To Len(R)
If Not (Mid(R, I, 1) = "/" Or IsNumeric(Mid(R, I, 1))) Then Mid(W, I, 1) = " "
Next
While InStr(W, " "): W = Replace(W, " ", " "): Wend
J = 0

Attention: la ligne en gras n'est pas conforme à ce que vous ai fourni et va faire boucler Excel à l'infini
je vous propose de la remplacer par :
While InStr(W, Space(2)): W = Trim(Replace(W, Space(2), Space(1))): Wend
Cela évitera les erreurs à l'indication des espaces en saisie ou en modif ... 🤗