Excel VBAからオブジェクト描画

質問

Outlookで管理している予定表を、諸事情から最終的にはExcelに落とさざるをえないので
相談にのっていただきたく投稿します。

場所　月日　午前/午後
---------------------
1 7/1 AM○/PM
2 7/3 AM　/PM○

というようなごく大まかなもので、
AM/PMのところに○の描画オブジェクトをかぶせています。

ただ文字でAM、PMと書くほうが簡単なのですが、
視覚的にわかりやすいのでこのようにすることになっています。
変更があったときなど、Outlookで直してからExcelの表を作り直すのが煩雑です。

OutlookでエクスポートしたデータをExcelにとりこみ、

場所　月日　開始時刻
---------------------
1 7/1 AM
2 7/3 PM

とするところまではできたのですが、このAM、PMという文字情報にあわせて
AMセル、PMセルに○オブジェクトを貼り付けるようなマクロはできないでしょうか？

回答No.1

keithin · ベストアンサー

所定の文字が記入されたセルを調べ，そのセルの大きさに合わせて（若しくは所定のサイズの）円を描きます。

＞このAM、PMという文字情報にあわせて
＞AMセル、PMセルに○オブジェクトを貼り付ける

作成例：
Sub macro1()
　Dim s As Shape
　Dim h As Range
　Dim p As String
　Dim a, i

　a = Array("AM", "PM")
　’activesheet.drawingobjects.delete　’必要に応じて調整

　For i = 0 To 1
　　Set h = Cells.Find(what:=a(i), LookIn:=xlValues, lookat:=xlWhole)
　　If Not h Is Nothing Then
　　　p = h.Address
　　　Do
　　　　　　　’必要に応じて丸の位置・サイズを調整
　　　　With ActiveSheet.Shapes.AddShape(msoShapeOval, h.Left + 10, h.Top + 3, h.Width - 20, h.Height - 6)
　　　　　.Fill.Visible = False
　　　　　.Line.Weight = 1
　　　　End With
　　　　Set h = Cells.FindNext(h)
　　　Loop Until p = h.Address
　　End If
　Next i
End Sub

＃実際にはご質問に書いてない色々細々した部分で，何かと調整等が必要と思われます。
　サンプルマクロを下敷きにして，必要な部分をご自分で手直してご利用下さい。

お礼

AddShapeメソッドと、特定セルの座標の得方を参考に、
目的のマクロを組むことができました。

ありがとうございました。