循环遍历一行直到空白

Question

我有下面的代码来执行以下操作。

它在A列中找到文本“EE Only”并记录行号。

然后它添加四个矩形，其中第一个在记录的行号中，另外三个在下面的三行中。

然后它格式化没有填充和黑色边框的矩形。

我将 dim c 作为 Integer 并且 c = 2。然后我将其用作列。到目前为止，一切正常。我遇到的问题是，对于第 3 行中有内容的 B 之后的每一列，我需要将列号增加一。换句话说；第一组形状将始终在 B 列中。之后，如果 C3 中有东西，那么我需要将列号增加 1 并将形状添加到 C 列。如果 D3 中有东西，将 c 增加 1 并添加形状到 D 列等等。第 3 行第一次为空白时，循环将停止。

我尝试了几种不同的方法，但我完全不知所措。我遇到的另一个问题是，如果我使用 c = 2 运行代码，则形状的格式会正确。如果我随后保留这些形状并手动更改为 c = 3 并再次运行代码，则新的形状集将填充蓝色。再次，尝试了我能找到的一切，但没有任何效果。

Sub AddShapes()
Const TextToFind As String = "EE Only"
Dim ws As Worksheet
Dim RowNum As Range

Dim SSLeft As Double
Dim SSTop As Double
Dim SS As Range
Set ws = ActiveSheet
Dim c As Integer
c = 2

Set RowNum = ws.Range("A:A").Find(what:=TextToFind, lookat:=xlWhole)
Set SS = Cells(RowNum.Row, c)
SSLeft = Cells(RowNum.Row, c).Left + (Cells(RowNum.Row, c).Width) / 4

'Add four rectangles
Dim y As Integer
For y = 0 To 3
    SSTop = Cells(RowNum.Row + y, c).Top + ((Cells(RowNum.Row + y, c).Height) / 2) - 5
    Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, SSLeft, SSTop, 10, 10)
Next

'Format them

ws.DrawingObjects.Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
    .Visible = msoTrue
    .Weight = 1
    .ForeColor.RGB = RGB(0, 0, 0)
    .Transparency = 0
End With

End Sub

Answer 1

我不是 100% 确定您的要求，但这是我对它的最佳解释。不是我为矩形部分定义了一个新的子程序，详情见 cmets

Sub AddShapes()
    Const TextToFind As String = "EE Only"
    Dim ws As Worksheet
    Dim RowNum As Range

    Set ws = ActiveSheet
    Dim c As Integer
    c = 2

    Set RowNum = ws.Range("A:A").Find(what:=TextToFind, lookat:=xlWhole)
    Call Rectangles(RowNum.row, c, ws) ' call the rectangles function for our first instance

    c = c+1 ' increment the column by one so we're not on the same column

    Do While Not IsEmpty(Cells(3,c).Value) 'Loop through each column until the 3rd row is empty
        Call Rectangles(3,c,ws) ' call our rectangles function on the 3rd row in the current column (c)
        c=c+1 ' increment the column
    Loop

End Sub

Sub Rectangles(row As Integer, c As Integer, ws As Worksheet) ' we define a separate sub to draw the rectangles so that we can call it again and again
    Dim SSLeft As Double
    Dim SSTop As Double
    Dim SS As Range
    Set SS = Cells(row, c)
    SSLeft = Cells(row, c).Left + (Cells(row, c).Width) / 4

    'Add four rectangles
    Dim y As Integer
    For y = 0 To 3
        SSTop = Cells(row + y, c).Top + ((Cells(row + y, c).Height) / 2) - 5
        Call ActiveSheet.Shapes.AddShape(msoShapeRectangle, SSLeft, SSTop, 10, 10)
    Next

    'Format them

    ws.DrawingObjects.Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 1
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
    End With
End Sub