Question

我有以下代码执行以下操作。

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

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

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

我将dim c作为Integer并且c = 2.然后我将其用作列。到目前为止，一切都正常运作。我遇到的问题是，在第3行中有某些内容的B之后，我需要每列的列数增加1。换句话说;第一组形状将始终位于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

循环直到空白

1 个答案: