我正在填充一个带有水印的大范围，我可以填充每个其他单元格吗？加快速度

Question

宏使用临时水印填充大范围我可以调整范围以填充范围内的每隔一行或每隔 5 个单元格等吗？因为目前它是不可能慢。

理想情况下，我想每隔一个单元格填充它一次，我只是想不出设置范围而不崩溃的正确方法。

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

我已经加入了一项规定，您可以跳过行和列而无需遍历它们，从而使您的代码更快

我已将循环方式从 For Each cll In rng 更改为 For r = 1 To MaxRows Step 2 其中 r 是行号，步进函数将帮助您跳过行。

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

Answer 2

您可以使用

填充任何其他列

If cll.Column Mod 2 = 0 Then

就在您的 For...Each

之后

更进一步，您可以检查列和行。此代码将在 B 列中放置 1，在奇数行上放置 D 和 F，在偶数行上放置 A、C、E 和 G - 您只需要将放置形状移动到一个单独的过程中。

Sub Test()

    Dim rng As Range
    Dim cll As Range
    Dim shp As Shape
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rng = ws.Range("A1:G5000")

    For Each cll In rng
            If cll.Row Mod 2 = 1 And cll.Column Mod 2 = 0 Then
                'Call a place shape procedure.
                cll.Value = 1
            ElseIf cll.Row Mod 2 = 0 And cll.Column Mod 2 = 1 Then
                'Call a place shape procedure.
                cll.Value = 1
            End If
    Next cll

End Sub

我正在填充一个带有水印的大范围，我可以填充每个其他单元格吗？加快速度

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

excel

performance

vba

processing-efficiency