excel - Insert text into the background of a cell

Question

I am looking for a way to insert text into the background of a cell, so that I can still enter numbers on top of that text - similar to a watermark except for an individual cell. Any ways to do this, preferably without using a macro (but open to these solutions as well)?

Answer 1

Similar to Andrews post, this is the VBA version which formats the shape correctly and also allows direct selecting of cells.

Code MODULE:

Sub watermarkShape()
Const watermark As String = "watermark"
Dim cll As Range
Dim rng As Range
Dim ws As Worksheet
Dim shp As Shape

    Set ws = Sheet1
    Set rng = ws.Range("A1:F10") 'Set range to fill with watermark

    Application.ScreenUpdating = False

    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    For Each cll In rng

        Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)

        With shp
            .Left = cll.Left
            .Top = cll.Top
            .Height = cll.Height
            .Width = cll.Width

            .Name = cll.address
            .TextFrame2.TextRange.Characters.Text = watermark
            .TextFrame2.TextRange.Font.Name = "Tahoma"
            .TextFrame2.TextRange.Font.Size = 8
            .TextFrame2.VerticalAnchor = msoAnchorMiddle
            .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .TextFrame2.WordWrap = msoFalse
            .TextFrame.Characters.Font.ColorIndex = 15
            .TextFrame2.TextRange.Font.Fill.Transparency = 0.35

            .Line.Visible = msoFalse
'            Debug.Print "'SelectCell (""" & ws.Name & """,""" & cll.address & """)'"
            .OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"

            With .Fill
                .Visible = msoTrue
                .ForeColor.ObjectThemeColor = msoThemeColorBackground1
                .Transparency = 1
                .Solid
            End With

        End With


    Next cll

    Application.ScreenUpdating = True
End Sub

Sub SelectCell(ws, address)
    Worksheets(ws).Range(address).Select
End Sub

UPDATE:

the example below assigns a watermark of the cell address to odd rows and leaves the even rows as the constant watermark. This is an exaple based on my comment that any cell can be assigned any watermark text based on whatever conditons you want.

Option Explicit

Sub watermarkShape()
Const watermark As String = "watermark"
Dim cll As Range
Dim rng As Range
Dim ws As Worksheet
Dim shp As Shape

    Set ws = Sheet1
    Set rng = ws.Range("A1:F10") 'Set range to fill with watermark

    Application.ScreenUpdating = False

    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    For Each cll In rng

        Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)

        With shp
            .Left = cll.Left
            .Top = cll.Top
            .Height = cll.Height
            .Width = cll.Width

            .Name = cll.address
            If cll.Row Mod 2 = 1 Then
                .TextFrame2.TextRange.Characters.Text = cll.address
            Else
                .TextFrame2.TextRange.Characters.Text = watermark
            End If
            .TextFrame2.TextRange.Font.Name = "Tahoma"
            .TextFrame2.TextRange.Font.Size = 8
            .TextFrame2.VerticalAnchor = msoAnchorMiddle
            .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .TextFrame2.WordWrap = msoFalse
            .TextFrame.Characters.Font.ColorIndex = 15
            .TextFrame2.TextRange.Font.Fill.Transparency = 0.35

            .Line.Visible = msoFalse
'            Debug.Print "'SelectCell (""" & ws.Name & """,""" & cll.address & """)'"
            .OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"

            With .Fill
                .Visible = msoTrue
                .ForeColor.ObjectThemeColor = msoThemeColorBackground1
                .Transparency = 1
                .Solid
            End With

        End With


    Next cll

    Application.ScreenUpdating = True
End Sub

Sub SelectCell(ws, address)
    Worksheets(ws).Range(address).Select
End Sub