• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:条件付き書式でいろをつけたセルに図形を重ねるマクロ)

条件付き書式で図形を重ねるマクロ

このQ&Aのポイント
  • 条件付き書式を使用してセルに色をつけるマクロを作成する方法について
  • 結合されたセルに図形を重ねて、セル内の文字を囲む方法について
  • 範囲内のセルに色がついた箇所を判定して図形を重ねる方法について

質問者が選んだベストアンサー

  • ベストアンサー
  • imogasi
  • ベストアンサー率27% (4737/17069)
回答No.1

条件付き書式を設定して、条件に該当分は書式で、一応目立つようになっていると思うが、さらに装飾を加える必要があるのかな。自分がやれるなら存分にやればよいが、質問までして、他人に教えてもらって、まる写しして、やるべきことか疑問。 質問者で達成済みの書式は、セルの「塗りつぶし」だとして、その詳細は、質問には書いてないので、それはそのままに、その塗りつぶしのあるセルを割り出し、その後に丸を追加するようなことを考えてみた。 小生の思い違いでうまく行かない場合は捨ててください。 ーー エクセルには「書式による検索」機能があるのはご存じか? それを使ってみた。「書式による検索 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 で一遍に図形を消せる。

AkB373
質問者

お礼

ご回答ありがとうございました。 参考にさせていただきます。

その他の回答 (1)

回答No.2

' ' 〓〓 標準モジュール 〓〓(シートモジュール不可) ' ' // 対象シート(コピー元とコピー先を含む)をアクティブにしてから実行。 ' ' // 貼付け先候補となるセル範囲を選択してから実行 ' ' > 条件に該当するセルに条件付き書式で色をつけました ' ' [条件付き書式][セルの書式][塗りつぶし][背景色]に単色のみ設定した場合の例です ' ' もしフォント色など、他の設定のことだった場合など、 ' ' 不足があれば、詳しく補足ください 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 ' ' 〓〓

AkB373
質問者

お礼

ご回答ありがとうございました。 参考にさせていただきます。