- ベストアンサー
条件付き書式で図形を重ねるマクロ
- 条件付き書式を使用してセルに色をつけるマクロを作成する方法について
- 結合されたセルに図形を重ねて、セル内の文字を囲む方法について
- 範囲内のセルに色がついた箇所を判定して図形を重ねる方法について
- みんなの回答 (2)
- 専門家の回答
質問者が選んだベストアンサー
条件付き書式を設定して、条件に該当分は書式で、一応目立つようになっていると思うが、さらに装飾を加える必要があるのかな。自分がやれるなら存分にやればよいが、質問までして、他人に教えてもらって、まる写しして、やるべきことか疑問。 質問者で達成済みの書式は、セルの「塗りつぶし」だとして、その詳細は、質問には書いてないので、それはそのままに、その塗りつぶしのあるセルを割り出し、その後に丸を追加するようなことを考えてみた。 小生の思い違いでうまく行かない場合は捨ててください。 ーー エクセルには「書式による検索」機能があるのはご存じか? それを使ってみた。「書式による検索 VBA」WEB照会すれば記事が相当出てくる。それをアレンジしたもの。 (1)まず小生のテストでは、塗りつぶしの色は黄色でやった。質問者の条件付き書式で付けた色(コード)と下記のコードの下記部分合わせてください。 .Interior.Color = 65535 の部分。 (2)丸の形と塗りつぶしの色は、好みに変えるなら、下記コードを修正のこと (3)シートに乗せた図形は、セル幅などを利用者が変えると、その変動に連れて変動させる方法仕組みが、エクセルにあるが、その部分までは考慮してない。 (4)丸の位置はセルの左位置にしてあるが、真ん中だと、(セルの左辺位置)+(セル幅÷2)ー(円の幅÷2) とでもするのかな。 数字だと右詰めであり、下記のままでよいのかな、と思うが、セルの文字列の場合は、丸が中央では、丸と地の文字列が衝突して見にくいのでは無いかと思う。透過など考えるのは面倒くさいので略。 Sub test03() Dim myRng As Range Dim cl As Range '--.FindFormatの設定 With Application.FindFormat '書式検索条件を初期化 .Clear 'セル背景色を設定(黄色) .Interior.Color = 65535 'フォントスタイルの設定(イタリック体) '.Font.Italic = True End With '-- '書式で検索、値はワイルドカードを指定 Set myRng = Range("A2:I22").Find(What:="*", SearchFormat:=True) If myRng Is Nothing Then MsgBox "該当データはありません" Exit Sub Else MsgBox myRng.Address With myRng ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left + 2, Top:=.Top + 2, Width:=20, Height:=.Height - 2).Select End With firstAddress = myRng.Address End If '--第2件該当以後 Set Rng = myRng Do Set myRng = Range("A2:I22").Find(What:="*", _ After:=myRng, _ SearchFormat:=True) If myRng Is Nothing Then Exit Do If myRng.Address = firstAddress Then Exit Do MsgBox myRng.Address With myRng ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left + 2, Top:=.Top + 2, Width:=20, Height:=.Height - 2).Select End With Set Rng = Union(Rng, myRng) Loop End Sub VBAでの検索では、該当第1発見と、その後の該当発見を分けなければならないので、初心者にはややこしいので、あまり勧めないが、本件はやむを得ない。 参考 もし上記の丸以外に、張り付けている図形などが、すでにない!場合は、テストしていて、丸を消して、変えたコードを実行して、何度もやりたいことがあろう。その場合は Sub test04() ActiveSheet.DrawingObjects.Delete End Sub で一遍に図形を消せる。
その他の回答 (1)
- real beatin(@realbeatin)
- ベストアンサー率82% (174/211)
' ' 〓〓 標準モジュール 〓〓(シートモジュール不可) ' ' // 対象シート(コピー元とコピー先を含む)をアクティブにしてから実行。 ' ' // 貼付け先候補となるセル範囲を選択してから実行 ' ' > 条件に該当するセルに条件付き書式で色をつけました ' ' [条件付き書式][セルの書式][塗りつぶし][背景色]に単色のみ設定した場合の例です ' ' もしフォント色など、他の設定のことだった場合など、 ' ' 不足があれば、詳しく補足ください Sub ReW9132373() ' Excel2010以降のバージョン限定 Const XOFF As Single = -1.5 ' 横方向の位置、微調整 ■適宜指定■ Const YOFF As Single = -1 ' 縦方向の位置、微調整 ■適宜指定■ Dim c As Range Dim fc As FormatCondition Dim nXOff As Single, nYOff As Single Dim X As Single, Y As Single Dim nDispColor As Long Dim nFCColor As Long ' Range("G7:AK24").Select If TypeName(Selection) <> "Range" Then MsgBox "セル範囲を選択": Exit Sub Application.ScreenUpdating = False With ActiveSheet ' ' あらかじめ図形で作成しておいた〇(Oval1という名前)... "Oval1" ? "Oval 1" ? With .Shapes("Oval 1") ' 楕円図形の オブジェクト名 は ■正確に!!指定■ nXOff = XOFF - .Width / 2: nYOff = YOFF - .Height / 2 .Copy End With For Each c In Selection.SpecialCells(xlCellTypeAllFormatConditions) If c.MergeArea(1).Address = c.Address Then nDispColor = c.DisplayFormat.Interior.Color nFCColor = True For Each fc In c.FormatConditions nFCColor = fc.Interior.Color If nFCColor = nDispColor Then Exit For Next If nFCColor = nDispColor Then With c.MergeArea X = .Left + .Width / 2 + nXOff Y = .Top + .Height / 2 + nYOff End With c.PasteSpecial With .Shapes(.Shapes.Count) .Left = X: .Top = Y End With End If End If Next End With ActiveCell.Activate Application.ScreenUpdating = True End Sub ' ' // アクティブシートのShapesの内、Pictureタイプのものをすべて削除 Sub DelAdded() 'Op W9132373 Dim o As Shape For Each o In ActiveSheet.Shapes If o.Type = msoPicture Then o.Delete Next End Sub ' ' 〓〓
お礼
ご回答ありがとうございました。 参考にさせていただきます。
お礼
ご回答ありがとうございました。 参考にさせていただきます。