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!
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.
bonjour
dans le même style que AL 22
le mask ne peut être que "Date:"
VB:
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
Bonjour,
Une autre méthode qui ne perturbera pas d'éventuelles MFC et qui accepte des cellules fusionnées:
VB:
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
VB:
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 ...
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?
Bien vu, j'avais pas verrouillé le code sur les multi sélections :
VB:
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
Bonjour,
Une autre méthode qui ne perturbera pas d'éventuelles MFC et qui accepte des cellules fusionnées:
VB:
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
VB:
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 ...
Bien vu, j'avais pas verrouillé le code sur les multi sélections :
VB:
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