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＆amp;奇数行上的F和A，C，E＆amp; 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

我用水印填充大范围，我可以填充其他所有单元格吗？加快速度

2 个答案: