![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?a65a0e2)
現在下記のマクロで複数セルに一度に〇印(楕円)をつける作業をしています。
やりたいこと
①セルの幅に合わせて〇をつける(楕円ではなく円)・・・縦長のセルのため
②結合したセルには一つの〇(円)が描かれるようにする(現在はセル数分〇印が描かれてしまう)。
以上です。どなたか記述を修正していただけませんでしょうか。
Sub 選択した複数セルに〇印()
For Each r In Selection
Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
s.Fill.Visible = msoFalse
s.IncrementLeft 0
s.IncrementTop 0
With s.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
Next
End Sub
No.4ベストアンサー
- 回答日時:
こんにちは
>①セルの幅に合わせて〇をつける
「幅」に合わせるという決め打ちで良いのなら、No1様の回答にある通り、サイズを幅で決めるようにすればよいです。
セル形状が不明の場合は、縦横の小さい方の値を採用すれば宜しいでしょう。
表示位置をどこにするのかご質問文にないのではっきりとしませんが、左上合わせとか中央合わせとかはサイズを決めてから計算すれば良いでしょう。
>②結合したセルには一つの〇(円)が描かれるようにする
For Eachでループさせているので、結合セルの場合はその構成セル数分だけループすることになりますので、現状のままだとその個数分描かれることになります。
仮に結合セルが無くても、複数のセル範囲を重なりがあるように選択してループすると、重なっている部分は重複してカウントされるので、同様のことが発生します。
これを回避するには、選択セルの内容を解析して(結合セルを含め)重複が無いようにしてからループすれば良いですが、解析するのが結構面倒ですね。
代替案として、(効率はやや落ちますが)「セル内の作成された円」を削除してから円を描くようにすれば、結果的に必ずひとつだけ残ることになります。
以下は、そのような方法での一例です。
※ 作成する円は、セルに対して中央合わせにしてあります。
※ 非表示セルには図形を描けないので、非表示セルは飛ばしています。
(一旦、表示してから描けば描けますけれど・・)
※ 当該マクロで作成した図形以外の図形はそのまま残ります。
※ 選択内容がセル範囲ではない場合には何もしません。
Sub Sample()
Dim r As Range, c As Range, s As Shape
Dim x As Single, y As Single, z As Single
If TypeName(Selection) <> "Range" Then Exit Sub
For Each r In Selection.Cells
If Not (r.EntireRow.Hidden Or r.EntireColumn.Hidden) Then
Set c = r.MergeArea
For Each s In ActiveSheet.Shapes
If Not Intersect(c, Range(s.TopLeftCell, s.BottomRightCell)) Is Nothing Then
If s.AlternativeText = "HOGE_OVAL" Then s.Delete
End If
Next s
z = Application.Min(c.Width, c.Height) - 2
x = c.Left + (c.Width - z) / 2
y = c.Top + (c.Height - z) / 2
With ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, z, z)
.Fill.Visible = msoFalse
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Transparency = 0
.Line.Weight = 1.5
.AlternativeText = "HOGE_OVAL"
End With
End If
Next r
End Sub
本当にありがとうございます。懇切丁寧なご説明までいただき感謝申し上げます。一つづつ調べながら理解しようと努めているところです。
思った通りに〇印を書くことができ大変助かりました。
No.3
- 回答日時:
#2です
動くけれど違うようなので訂正
Dim wh As Double
Property Height As Single
Excel.Shape のメンバー なので
Dim wh As Single
Set r = r.MergeArea
ループに使っているRangeオブジェクトを再セットは良くないかも知れません
新たに Rangeオブジェクト変数をたてる方が好ましいと思います
No.2
- 回答日時:
こんにちは
ちょっと改造して
Sub 選択した複数セルに〇印()
Dim r As Range, s As Shape
Dim wh As Double
For Each r In Selection
If r.Address = r.MergeArea(1).Address Then
Set r = r.MergeArea
wh = WorksheetFunction.Min(r.Width, r.Height)
Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, r.Left, r.Top, wh, wh)
s.Left = r.Left + (r.Width - s.Width) / 2
s.Top = r.Top + (r.Height - s.Height) / 2
s.Fill.Visible = msoFalse
s.IncrementLeft 0
s.IncrementTop 0
With s.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
End If
Next
End Sub
If r.Address = r.MergeArea(1).Address Then
Set r = r.MergeArea
この書き方は調べてみてください
No.1
- 回答日時:
>AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
高さも横幅で指定する。
AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Width)
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Visual Basic(VBA) 指定の条件に応じたセルの場所に〇印(図形)を描く 2 2022/11/08 15:26
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Excel(エクセル) 日付で矢印マクロ 4 2023/07/25 16:47
- Visual Basic(VBA) QRコード作成マクロについて 3 2022/11/26 16:55
- Excel(エクセル) 判定結果に応じて〇印(図形)をつけるマクロ 4 2022/10/30 11:22
- Visual Basic(VBA) EXCEL VBAにて動的にCheckBOXを複数作成し、同BOXにイベントを追加したい 1 2023/03/16 07:05
- PowerPoint(パワーポイント) ExcelのVBAコードについて教えてください。 3 2022/05/25 14:32
- Visual Basic(VBA) ExcelVBAのマクロについて。 9 2022/05/04 14:50
- Excel(エクセル) Excelのマクロについて教えてください。 4 2022/05/31 14:07
このQ&Aを見た人はこんなQ&Aも見ています
-
これまでで一番「情けなかったとき」はいつですか?
これまでの人生で一番「情けない」と感じていたときはいつですか? そこからどう変化していきましたか?
-
何回やってもうまくいかないことは?
みなさんには、何回やってもうまくいかないことはありますか?
-
もし10億円当たったら何に使いますか?
みなさんの10億円プランが知りたいです!
-
コーピングについて教えてください
皆さんはストレスを感じたとき、どのような方法や手段、テクニックで対処していますか?
-
思い出すきっかけは 音楽?におい?景色?
記憶をふと思い出すきっかけは 音楽、におい、景色 どれですか?
-
セルをクリック⇒そのセルに入力された文字を○で囲む
Excel(エクセル)
-
VBAで丸をつけたいです。
その他(プログラミング・Web制作)
-
Excel VBA素人です。VBAで図形のセンタリング方法ご教示下さい
Visual Basic(VBA)
-
-
4
Excel(VBA)
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・一番好きなみそ汁の具材は?
- ・泣きながら食べたご飯の思い出
- ・「これはヤバかったな」という遅刻エピソード
- ・初めて自分の家と他人の家が違う、と意識した時
- ・いちばん失敗した人決定戦
- ・思い出すきっかけは 音楽?におい?景色?
- ・あなたなりのストレス発散方法を教えてください!
- ・もし10億円当たったら何に使いますか?
- ・何回やってもうまくいかないことは?
- ・今年はじめたいことは?
- ・あなたの人生で一番ピンチに陥った瞬間は?
- ・初めて見た映画を教えてください!
- ・今の日本に期待することはなんですか?
- ・集中するためにやっていること
- ・テレビやラジオに出たことがある人、いますか?
- ・【お題】斜め上を行くスキー場にありがちなこと
- ・人生でいちばんスベッた瞬間
- ・コーピングについて教えてください
- ・あなたの「プチ贅沢」はなんですか?
- ・コンビニでおにぎりを買うときのスタメンはどの具?
- ・おすすめの美術館・博物館、教えてください!
- ・【お題】大変な警告
- ・洋服何着持ってますか?
- ・みんなの【マイ・ベスト積読2024】を教えてください。
- ・「これいらなくない?」という慣習、教えてください
- ・今から楽しみな予定はありますか?
- ・AIツールの活用方法を教えて
- ・最強の防寒、あったか術を教えてください!
- ・歳とったな〜〜と思ったことは?
- ・モテ期を経験した方いらっしゃいますか?
- ・好きな人を振り向かせるためにしたこと
- ・スマホに会話を聞かれているな!?と思ったことありますか?
- ・それもChatGPT!?と驚いた使用方法を教えてください
- ・見学に行くとしたら【天国】と【地獄】どっち?
- ・これまでで一番「情けなかったとき」はいつですか?
- ・この人頭いいなと思ったエピソード
- ・あなたの「必」の書き順を教えてください
- ・14歳の自分に衝撃の事実を告げてください
- ・人生最悪の忘れ物
- ・あなたの習慣について教えてください!!
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excel VBA 空白セルがあったら...
-
VBA 別ブックから条件に合うも...
-
クリップボードの内容を変数に...
-
Excel 入力規則のリストのカー...
-
VBA 文字列を1文字ずつ調べて"...
-
【VBA】セルが空白の場合に処理...
-
Excel VBA コンボボックスで空...
-
SPREADで1つのセルに複数のチ...
-
マウスを乗せたときにセルの色...
-
■EXCEL(二つのセルの文字列を一...
-
Excelマクロで空白セルの大小比...
-
エクセルの取り消し線を検出す...
-
JTableにおけるセルの結合について
-
Excel_VBAについて質疑です。(...
-
GridViewの行選択イベントを発...
-
エクセル: セルの枠を超えて表示
-
エクセル:マクロ「Application...
-
エクセルでの計算式で求められ...
-
EXCELで特定のセルに表示...
-
IF関数で空欄("")の時、Null...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel VBA 空白セルがあったら...
-
VBA 別ブックから条件に合うも...
-
Excel VBA コンボボックスで空...
-
Excel 入力規則のリストのカー...
-
クリップボードの内容を変数に...
-
マウスを乗せたときにセルの色...
-
複数セルに〇印をつけるマクロ
-
【VBA】セルが空白の場合に処理...
-
Excelマクロで空白セルの大小比...
-
マクロについて質問です 範囲内...
-
エクセルの取り消し線を検出す...
-
GridViewの行選択イベントを発...
-
VBA サンダーバードのメール自...
-
【VB.NET】DataGridViewセルの...
-
VBA 文字列を1文字ずつ調べて"...
-
エクセル チェックボックスの...
-
■EXCEL(二つのセルの文字列を一...
-
DataGridViewでセルを結合したい
-
VBA で選択した範囲に入力され...
-
vbaで色付けされたセルを除外し...
おすすめ情報