XL 2019 Ecrire un texte en fond de cellule

[marie21lc]

Bonjour,
Je souhaite écrire un texte en fond de cellule grisé (par ex : date), que cette donnée disparaisse quand l'utilisateur du fichier écrit et réapparaisse si l'utilisateur efface.
ca ne fonctionne pas en faisant via le format de cellule [=0]"A remplir avec la date";Standard
car cela disparait une fois que l'on a écrit..
merci pour votre aide!

 

[AL 22]

Bonjour,

En pièce jointe, un classeur avec une macro (si cela ne vous rebute pas) qui fait ce que vous demandez.
Bien sûr, il faudra l'adapter à votre classeur.

Cordialement

AL 22

 

[patricktoulon]

bonjour
dans le même style que AL 22
le mask ne peut être que "Date:"

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Static mask$
    If Not Intersect(Target, Range("C3")) Is Nothing Then
        If Not IsDate(Target.Value) Then
            mask = Target.Value: Target = ""
            If mask = "" Or mask <> "Date:" Then mask = "Date:"
            [c3].Interior.Pattern = xlNone
        End If
    Else
        With [c3]: If Not IsDate(.Value) Then .Value = mask: .Interior.Pattern = xlGray8
        End With
    End If
End Sub

 

[fanch55]

Bonjour,
Une autre méthode qui ne perturbera pas d'éventuelles MFC et qui accepte des cellules fusionnées:

Spoiler: A mettre dans un Module de votre classeur

Option Explicit
Sub Set_Filigrane()
Dim Box As Object
Dim Cel As Range
   
    If ActiveCell.Count > 1 Then Exit Sub
   
    Set Cel = ActiveCell.MergeArea
    On Error Resume Next
        ActiveSheet.Shapes(Cel.Cells(1).address).Delete
    On Error GoTo 0
    Set Box = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Cel.Left, Cel.Top, Cel.Width, Cel.Height).OLEFormat.Object
    With Box
        .Name = Cel.Cells(1).address
        .Text = "Entrez une date"
        .Border.LineStyle = 0
        .Font.Name = Cel.Font.Name
        .Font.Size = Cel.Font.Size
        .Font.Italic = True
        .Interior.Pattern = xlNone
        .Font.Color = 11250607
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .OnAction = "SelCell"
    End With
End Sub
Sub SelCell()
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Select
End Sub
Sub Set_Shp(Target)
Dim Shp As Shape
    On Error Resume Next
        Set Shp = ActiveSheet.Shapes(Target(1).address)
        If Not Shp Is Nothing Then Shp.Visible = Target(1) = vbNullString
    On Error GoTo 0

End Sub

Spoiler: A mettre dans le code de la feuiille

Private Sub Worksheet_Change(ByVal Target As Range)
    Set_Shp Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set_Shp Target
End Sub

Mise en œuvre :
Sélectionnez la cellule pour laquelle vous voulez le filigrane
et exécuter la sub Set_Filigrane ( normalement à ne faire qu'une fois ).
Après, utilisez votre classeur comme d'habitude ...

Classeur joint pour exemple .

 

[patricktoulon]

re
@fanch55
sauf que quand on sélectionne la cellules et que l'on en sélectionne une autre le filigrane ne revient pas
ps: tu a un peu travaillé sur l'alignement de texte ou pas
tu a testé mon msgbox perso?

 

[fanch55]

re
@fanch55
sauf que quand on sélectionne la cellules et que l'on en sélectionne une autre le filigrane ne revient pas

Bien vu, j'avais pas verrouillé le code sur les multi sélections :

Sub Set_Shp(Target)
Dim Shp As Shape, Cel As Range
    For Each Cel In Target.Cells
        On Error Resume Next
            Set Shp = ActiveSheet.Shapes(Cel.address)
            If Not Shp Is Nothing Then Shp.Visible = Cel = vbNullString
            Set Shp = Nothing
        On Error GoTo 0
    Next
End Sub

 

[fanch55]

tu a testé mon msgbox perso?

Oui très rapidement, j'ai les boutons qui "débordent" vers la droite et je n'ai pas été plus loin ...
(j'ai pris le code mis dans les ressources)

 

[marie21lc]

Bonjour,
Une autre méthode qui ne perturbera pas d'éventuelles MFC et qui accepte des cellules fusionnées:

Spoiler: A mettre dans un Module de votre classeur

Option Explicit
Sub Set_Filigrane()
Dim Box As Object
Dim Cel As Range
  
    If ActiveCell.Count > 1 Then Exit Sub
  
    Set Cel = ActiveCell.MergeArea
    On Error Resume Next
        ActiveSheet.Shapes(Cel.Cells(1).address).Delete
    On Error GoTo 0
    Set Box = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Cel.Left, Cel.Top, Cel.Width, Cel.Height).OLEFormat.Object
    With Box
        .Name = Cel.Cells(1).address
        .Text = "Entrez une date"
        .Border.LineStyle = 0
        .Font.Name = Cel.Font.Name
        .Font.Size = Cel.Font.Size
        .Font.Italic = True
        .Interior.Pattern = xlNone
        .Font.Color = 11250607
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .OnAction = "SelCell"
    End With
End Sub
Sub SelCell()
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Select
End Sub
Sub Set_Shp(Target)
Dim Shp As Shape
    On Error Resume Next
        Set Shp = ActiveSheet.Shapes(Target(1).address)
        If Not Shp Is Nothing Then Shp.Visible = Target(1) = vbNullString
    On Error GoTo 0

End Sub

Spoiler: A mettre dans le code de la feuiille

Private Sub Worksheet_Change(ByVal Target As Range)
    Set_Shp Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set_Shp Target
End Sub

Mise en œuvre :
Sélectionnez la cellule pour laquelle vous voulez le filigrane
et exécuter la sub Set_Filigrane ( normalement à ne faire qu'une fois ).
Après, utilisez votre classeur comme d'habitude ...

Classeur joint pour exemple .

c'est exactement cela qu'il me faut. Je vais essayer merci !

 

[marie21lc]

Bien vu, j'avais pas verrouillé le code sur les multi sélections :

Sub Set_Shp(Target)
Dim Shp As Shape, Cel As Range
    For Each Cel In Target.Cells
        On Error Resume Next
            Set Shp = ActiveSheet.Shapes(Cel.address)
            If Not Shp Is Nothing Then Shp.Visible = Cel = vbNullString
            Set Shp = Nothing
        On Error GoTo 0
    Next
End Sub

est-ce que vous accepteriez de me remettre le fichier excel à jour ? merci !! (désolée pour le délai de réponse..)

 

[marie21lc]

Merci à chacun pour vos retours

 

[fanch55]

Bonjour,