判定結果に応じて〇印（図形）をつけるマクロ

ある点検表を作成しております。不備件数に応じて優、良、可、不可のセルに〇印が自動でつくようにしたいと考えています。
①不備件数B列　「空欄」（対象がない）＝該当なし　0件＝優　1件＝良　2.3件＝可　4件以上＝不可のセルに〇（図形）をつける
②判定欄は結合されたセルに〇をつける
③〇印は円で縦横の短い方に合わせる（この場合は横幅に合わせた円）
マクロ記述を教えていただきますと幸いです。何卒宜しくお願い致します。

No.3 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/10/30 17:00

シート名は「円を描く」にしてあります。

シート名を変えたい場合は、
Set ws = Worksheets("円を描く")
を変えてください。
円を描くマクロは、下記URLの内容をほぼそのまま利用しています。
https://infoment.hatenablog.com/entry/2018/07/01 …
以下のマクロを標準モジュールに登録してください。


Option Explicit
Public Sub 円を描く()
Dim ws As Worksheet
Dim wrow As Long
Dim wcol As Long
Dim maxrow As Long
Dim row_count As Long
Dim ng_count As Variant
Dim i As Long
Dim rg As Range
Dim sp As Shape
Set ws = Worksheets("円を描く")
maxrow = ws.Cells(Rows.count, "A").End(xlUp).Row '最大行取得
If maxrow < 2 Then Exit Sub
If maxrow Mod 2 <> 0 Then Exit Sub
row_count = maxrow \ 2
For Each sp In ws.Shapes
sp.Delete '図形を削除
Next
For i = 1 To row_count
wrow = (i - 1) * 2 + 2
ng_count = ws.Cells(wrow, 2).Value
Select Case ng_count
Case Is = ""
wcol = 3
Case Is < 1
wcol = 4
Case Is = 1
wcol = 5
Case 2, 3
wcol = 6
Case Is >= 4
wcol = 7
End Select
Set rg = ws.Range(ws.Cells(wrow, wcol), ws.Cells(wrow + 1, wcol))
Call MakeCircle(ws, rg)

Next
End Sub

Public Sub MakeCircle(ws As Worksheet, r As Range, Optional ρ As Double = 0.85, _
Optional myWeight As Double = 1.5)

Dim T As Double
Dim L As Double
Dim W As Double
Dim H As Double
Dim C As Shape

' 円の直径決定。セルの縦横を比較して、短い方を基準とする。
If r.Width >= r.Height Then
W = r.Height * ρ
Else
W = r.Width * ρ
End If

' 円のサイズと配置位置を決定。
H = W
T = r.Top + (r.Height - H) / 2
L = r.Left + (r.Width - W) / 2

' 円を描画。
Set C = ws.Shapes.AddShape(msoShapeOval, L, T, W, H)

C.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
C.Fill.Visible = msoFalse
C.Line.Weight = myWeight
End Sub

この回答へのお礼

どうもありがとうございます。思ったとおりの結果となり大変うれしく思っております。お手数をおかけいたしました。

お礼日時：2022/10/30 19:47

No.4 回答者： fujillin 回答日時： 2022/10/30 18:33

こんばんは

ご自身で作成するつもりがあるのか、丸投げなのかよくわかりませんけれど・・
ご質問文にない部分は勝手に以下のように解釈しました。

・対象はB列の偶数行（2、4、6・・）に固定
・ただし、B列は空白の値もあるので、最終行はA列で判断する
・〇印は偶数行にあるセルの結合範囲とする
・〇印は「既定の書式」で描きますので、個別に設定したい場合は
　追加してください。

同様に、仮定と異なる内容の部分については修正願います。

Sub Q_13208599()
Dim rw As Long, v As Long
Dim c As Range, L As Double

For rw = 2 To Cells(Rows.Count, 1).End(xlUp).Row Step 2
With Cells(rw, 2)
If IsNumeric(.Value) Then
v = Application.Min(.Value + 2 + (.Value > 2), 5)
If .Value = "" Then v = 1
Set c = .Offset(, v).MergeArea
L = Application.Min(c.Width, c.Height)
ActiveSheet.Shapes.AddShape msoShapeOval, _
c.Left + c.Width / 2 - L / 2, c.Top + c.Height / 2 - L / 2, L, L
End If
End With
Next rw
End Sub

No.2 回答者： tatsumaru77 回答日時： 2022/10/30 14:53

１．○をつけるセルが結合セルになっていますが、実際のシートも結合セルになっていますか。

２．レイアウトは、提示された図の通りで間違いないでしょうか。

３．実際には５件ではなく、項目（A列）の最後の行まで、処理すれば良いですか。それとも５件固定でよいのでしょうか。

この回答へのお礼

ご質問をありがとうございます。
1．実際も結合セルとなっております。
2．レイアウトは図のとおりです。
3．実際は10件あり最後の列まで処理していただければ幸いです。
よろしくお願いいたします。

お礼日時：2022/10/30 16:52

No.1 回答者： zircon3 回答日時： 2022/10/30 11:42

記入者が入力した値がどういう場合に「優」、どういう場合に「良」、どういう場合に「可」なのかを具体的にします。

判定基準の具体化・定量化ですね。
それを日本語を使って明確にします。何らかのチャート図を知っている場合はそれを使って書くとビジュアル的にも確認出来て誤りや漏れなどを防ぐことが出来ます。

それが出来たらその処理手順をプログラム言語に翻訳します。
丸を入れる位置はセルの位置で示します。

参考まで。

この回答へのお礼

お世話になっております。
アドバイスいただきましてありがとうございます。
参考にさせていただきます。

お礼日時：2022/10/30 16:54