循环行直到空白

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

它在列A中find文本“EE Only”并logging行号。

然后在logging的行号中添加四个矩形，其中三个矩形在下面的三行中。

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

我有昏暗的c整数和c = 2。然后，我用它作为列。 到目前为止，所有事情都应该如此。 我遇到的问题是，我需要在第3行中的B之后的每列都增加一个列号。换句话说， 第一组形状将总是在列B中。之后，如果在C3中有东西，那么我需要将列数加1，并将形状添加到列C.如果D3中有东西，则将c增加1并添加形状到D列等等。 第一次行3是空白的循环将停止。

我已经尝试了几个不同的东西，我完全丧失了。 我遇到的另一个问题是，如果我运行c = 2的代码的形状格式正确。 如果我然后离开这些形状，然后手动更改为c = 3并再次运行代码，则新的形状集具有蓝色填充。 再次，尝试了一切我能find，没有任何工作。

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