Heure en rouge ?

Bonjour,

Est-ce possible avec une macro que dans n'importe quelle cellule, la date soit mise en rouge automatiquement ?

Voir exemple joint.

Merci à vous.

Bonjour,

Pour le principe.

Cdlt.

Sub XXX()
Dim n As Double
    With ActiveCell
        n = WorksheetFunction.Find(Chr(10), .Value)
        .Characters(Start:=n + 1, Length:=5).Font.Color = -16776961
    End With
End Sub

Jean-Eric a écrit :

Bonjour,

Pour le principe.

Cdlt.

DJ_FA.xlsm

Sub XXX()
Dim n As Double
    With ActiveCell
        n = WorksheetFunction.Find(Chr(10), .Value)
        .Characters(Start:=n + 1, Length:=5).Font.Color = -16776961
    End With
End Sub

Ok extra, merci. Mais est-ce possible que ça agisse sans manipulation alt+f8 ?

Bonjour

Si tu n'as pas peur de ralentir ton application tu peux associer le code à l’événement WorkSheet_Change voire à Workbook_SheetChange en remplaçant ActiveCell par Target

Bonjour,

Je t'ai donné un exemple à partir de ton fichier. Soit une cellule !...

Précise ta demande avec un fichier représentatif de tes données et on verra pour la suite.

On ne va pas surveiller l'ensemble des cellules d'une feuille de calcul (17 179 869 184 cellules).

Cdlt.

Ok je te dit ça très vite.

Donc ça sera pour les cellules de ("H4:AK16").

Merci.

Bonjour,

Un fichier aurait été apprécié avec les différentes valeurs que l'on pouvait rencontrer dans ces cellules !...

Cdlt.

Jean-Eric a écrit :

Bonjour,

Un fichier aurait été apprécié avec les différentes valeurs que l'on pouvait rencontrer dans ces cellules !...

Cdlt.

Je viens de le mettre, j'avais oublié.

Re,

Voir fichier en retour.

Jean-Eric a écrit :

Re,

Voir fichier en retour.

TEST2.xlsm

Merci beaucoup Jean-Eric,

Juste une question, est-ce possible que les dates se mettent en rouge ?dès l'écriture, sans avoir à cliquer sur un bouton ?

Re,

Voir Feuil2 et sa procédure événemetielle.

Cdlt.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim txt As String, m As Long, n As Long
    If Target.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Me.Cells(4, 8).CurrentRegion) Is Nothing Then
        txt = Trim(Target.Text)
        m = Len(txt)
        n = WorksheetFunction.Find(Chr(10), txt)
        Target.Characters(Start:=n + 1, Length:=m).Font.Color = -16776961
    End If
End Sub

Excellent ! merci beaucoup.