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

macros填充一个简易的水印的大范围，我可以调整范围来填充范围内的每隔一行或每五单元格等？ 就目前而言，这是不可能的。

我想理想地填充它每隔一个单元格我只是不能找出正确的方式来设置范围而不会崩溃它。

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 to For r = 1 To MaxRows Step 2其中r是行号，step函数将帮助您跳过行。

 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 

就在你以后…每一个

更进一步，你可以检查列和行。 这段代码将在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