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