我用水印填充大範圍，我可以填充每個其他單元嗎？加速它

Question

宏填充一個簡易水印的大範圍我可以調整範圍來填充範圍內的每隔一行或每五單元格等？因爲目前它不可能很慢。

我想理想地填充它每隔一個單元我只是不能找出正確的方式來設置範圍而不會崩潰它。

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 

填充過其它列。此代碼將在奇數行上放置1列B，在偶數行上放置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