エクセルで図形を挿入するマクロについて

図形を挿入するマクロを考えています。

画像のように、Ａ列に番号・Ｂ列に商品名・Ｃ列に数量があります。
Ｃ列に数量が入っている場合のみ数量を○で囲みたいと思っています。

コードがわからないので、「マクロの記録」を利用して、出た結果を
加工しようとしたのですが、○を背景なしで２～３個入れても、
何も記録されませんでした。

どのようなコードを書けばよいのか、教えていただけませんか？

No.1 ベストアンサー 回答者： keithin 回答日時： 2011/02/20 19:55

一例です。

Sub Sample1()
　Dim h As Range
　On Error Resume Next
　ActiveSheet.Ovals.Delete
　For Each h In Range("C:C").SpecialCells(xlCellTypeConstants, xlNumbers)
　　With ActiveSheet.Shapes.AddShape(msoShapeOval, 120, h.Top, 35, 14)
　　　.Fill.Visible = False
　　　.Line.Weight = 0.1
　　　.Line.ForeColor.SchemeColor = 64
　　End With
　Next
End Sub

この回答へのお礼

思っていた結果が得られました。

ありがとうございます！

お礼日時：2011/02/20 21:37

No.3 回答者： imogasi 回答日時： 2011/02/20 21:03

Ｃ列の数字を対象にする

Ｃ列の行高は等しいものとする。
Shapes.Addでやらずにコピー貼り付けを利用した。
セルの値が空白に変わるようなことがあれば、再実行が必要。イベント処理せず。
ーー
Sub test01()
ActiveSheet.DrawingObjects.Delete
d = Range("C65536").End(xlUp).Row
h = Range("c1").Height
ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 0, 40, h).Select
x = Selection.Index
Selection.Copy
For i = 2 To d
Cells(i, "C").HorizontalAlignment = xlCenter
If Cells(i, "C") <> "" Then
ActiveSheet.Paste
Selection.ShapeRange.Left = Cells(i, "C").Left + 10
Selection.ShapeRange.Top = (i - 1) * h * 1#
Selection.ShapeRange.Fill.Visible = msoFalse
End If
Next i
ActiveSheet.Shapes(x).Delete
End Sub
---
長円の中に数字を納めるため、文字をセルの中央に配置している。しかしこれには異論もあろう。
空時桁に合わせて長円の大きさを変えるのはむつかしい。
ーー
＞、○を背景なしで２～３個入れても、何も記録されませんでした。
長円を「塗りつぶしなし」にしていないから、長円がセル数字を隠しているのでは。

No.2 回答者： Wendy02 回答日時： 2011/02/20 20:37

こういうマクロは、規定数（1000回から2000回）を越えると、オートシェイプが現れなくなることがあります。

その場合、シートを替えてリセットしないといけません。内部でカウントをしています。本来は、Visible =True/False で表示すれば、恒久的に使えます。

*数字は、右端にあるものとしています。　フォントサイズは、11ですから、サイズによって、i / 1.35の定数を調整する必要があります。数字の数によって、丸の大きさが変わります。

'//
Sub EnterCercles()
　Dim rng As Range
　Dim c As Range, shp As Object, i As Long
　Dim Lf#, tp#, w#, h#
　Set rng = Range("C1", Cells(Rows.Count, 3).End(xlUp))
　'最初にオートシェイプがある場合は削除します。
　For Each shp In ActiveSheet.Shapes
　　If Not Intersect(Columns(3), shp.TopLeftCell) Is Nothing Then
　　　shp.Delete
　　End If
　Next shp
　For Each c In rng.SpecialCells(xlCellTypeConstants, xlNumbers).Cells
　　With c
　　　i = Len(c.Text)
　　　If i > 1 Then i = i / 1.35 '注 フォントサイズ:　11
　　　w = .Height * i: Lf = .Offset(, 1).Left - w: tp = .Top: h = .Height
　　End With
　　With ActiveSheet.Shapes.AddShape(msoShapeOval, Lf, tp, w, h)
　　　.Line.ForeColor.SchemeColor = 10 '色は赤
　　　.Fill.Transparency = 0#
　　　.Fill.Solid
　　　.Line.Visible = msoTrue
　　　.Line.Weight = 0.75
　　　.Line.DashStyle = msoLineSolid
　　　.Line.Style = msoLineSingle
　　　.Line.Transparency = 0#
　　　.Fill.Visible = msoFalse
　　End With
　Next c

End Sub

この回答へのお礼

丸の大きさも変えられるのですね。
すごいです。

お礼日時：2011/02/20 21:39