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

Loic80

XLDnaute Nouveau
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
 

Loic80

XLDnaute Nouveau
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.
 

Pièces jointes

  • TABLEAU SUIVI PAV MODELE - Copie.xlsb
    43.6 KB · Affichages: 18

Loic80

XLDnaute Nouveau
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.
 

Pièces jointes

  • TABLEAU SUIVI PAV MODELE - Copie.xlsb
    41.6 KB · Affichages: 8

Phil69970

XLDnaute Barbatruc
Bonjour @Loic80 , @fanfan38

Je te propose :

VB:
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
 

fanch55

XLDnaute Barbatruc
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 ) .

VB:
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

XLDnaute Nouveau
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

XLDnaute Barbatruc
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 ... 🤗
 

Discussions similaires