I am populating a large range with a watermark, can i populate every other cell? to speed it up

Question

The Macro populates a large range with an improvised watermark can i adjust the range to populate every other row in the range or every 5th cell etc? as at the moment it is impossibly slow.

I would ideally like to populate it every other cell i just can't figure out the right way to set the range without crashing it.

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

Set ws = Worksheets("Custom")
Set rng = ws.Range("A1:G5000")  '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.5

        .Line.Visible = msoFalse

        .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

Answer 1

I have put in a provision where you can skip rows and columns without looping through them, thereby making your code faster

I have changed the way you loop from For Each cll In rng to For r = 1 To MaxRows Step 2 Where r is the row number and the step function will help you skip rows.

Sub watermarkShape()
Const watermark As String = "School Name"
Dim cll As Range
Dim ws As Worksheet
Dim shp As Shape
Dim rng As Range
Dim MaxRows As Integer, r As Integer
Dim MaxCols As Integer, c As Integer

Set ws = Worksheets("Custom")
Set rng = ws.Range("A1:G5000")  'Set range to fill with watermark

MaxRows = rng.Rows.Count 'Set the Total Number of rows that needs to be updated
MaxCols = rng.Columns.Count  'Set the Total Number of Columns that needs to be updated

Application.ScreenUpdating = False

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

For r = 1 To MaxRows Step 2 'The Step 2 defines how you want to populate the rows so step 2 will put the shape in every alternate row. You can try Step 5 etc.,
    For c = 1 To MaxCols Step 1 'The Step 1 defines how you want to populatethe Columns so step 2 will put the shape in every alternate row. You can try Step 5 etc.,
        Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)
        Cells(r, c).Select
        Set cll = ActiveCell
        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.5

            .Line.Visible = msoFalse

            .OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"

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

        End With
    Next c
Next r


 Application.ScreenUpdating = True

End Sub

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