空白まで行をループします。

Question

以下のコードでは以下のことができます。

列Aでテキスト "EE Only"を検索し、行番号を記録します。

次に、記録された行番号の最初の四角形と、下の3行の残りの3つの四角形を追加します。

次に、塗りつぶしと黒い枠線で四角形をフォーマットします。

私は整数としてdim cを持ち、c = 2です。それをその列として使用します。これまでのところ、すべてがうまくいっています。私が抱えている問題は、行3に何かを持っているBの後のすべての列に対して、列番号が1つ増える必要があるということです。最初の図形セットは常にB列になります。その後C3に何かがある場合は、列番号を1つ増やしてC列にシェイプを追加する必要があります。D3に何かがある場合、cを1増やして形状を列Dに変換する。最初の行3が空白の場合、ループは停止します。

私はいくつかのことを試しましたが、私は完全に迷っています。もう1つの問題は、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