循环行直到空白

Question

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

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

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

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

我有昏暗的c整数和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％确定您的要求，但这是我对它的最好解释。不是我为矩形部分定义了一个新的子程序，请参阅注释

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