指定の条件に応じたセルの場所に〇印（図形）を描く

Sheet1が個人のアンケ―トのデータ
Sheet2はそのアンケート結果を〇印を描いたものです
例えばアンケート1に対し「満足」と記入いただいた場合、Sheet2のアンケ―ト1の満足の欄に〇印をつけます。sheet2の「満足」B列　「普通」C列　「不満足」D列　です。
アンケート内容の部分は列が統一されていますが、性別は違う列となります。
添付の場合はsheet2のA2セル、B7セル、D9セルに〇印をつけたいのですがうまくいかずどこを直せばよいかどうしてもわかりません。下記記述を見ていただき修正願えませんでしょうか。（知的素養が不足しているため記述の仕方も野暮ったいと思いま）。

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")

If Range("B6") = "満足" Then
ws2.Activate
Range("B7").Select
ws1.Activate
ElseIf Range("B6") = "普通" Then
ws2.Activate
Range("C7").Select
ws1.Activate
ElseIf Range("B6") = "不満" Then
ws2.Activate
Range("D7").Select

End If
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 = ws2.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

If Range("B8") = "満足" Then
ws2.Activate
Range("B9").Select
ws1.Activate
ElseIf Range("B8") = "普通" Then
ws2.Activate
Range("C9").Select
ws1.Activate
ElseIf Range("B8") = "不満" Then
ws2.Activate
Range("D9").Select

End If
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 = ws2.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

ws1.Activate
If Range("A2 ") = "男" Then
ws2.Activate
Range("A2").Select
ws1.Activate
ElseIf Range("A2") = "女" Then
ws2.Activate
Range("A3").Select

End If

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 = ws2.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
Application.ScreenUpdating = True

End Sub

No.2 ベストアンサー 回答者： fujillin 回答日時： 2022/11/08 17:14

こんにちは

Sheet2に図形で丸をつけたいってことだと思いますけれど・・

なぜ、図形なんでしょうね？
文字の「○」等で良ければ簡単に関数で対応可能ですし、その後集計などをする際にも、図形の丸では処理が面倒になるだけと思いますが。
視認性が良くなってるかと考えてみても、Sheet1のままと変わらないように思います。
また、結合セルがなぜあるのかも不明ですけれど・・

＞sheet2のA2セル、B7セル、D9セルに〇印をつけたい
画像が良く読めないけれど、なんとなく、Sheet1は「男」、「満足」、「満足」のように見えますけれど、その結果がA2、B7、D9になる理屈がわかりません。
「B9」ならば理解できますけれど・・・


ですので、勝手に「A2、B7、B9」になるものと解釈して、以下一例です。
（シート名やセル位置等は決め打ちにしてあります）
似た様な処理の繰り返しなので、少しだけ一般化して再利用すれば、コンパクトにできると思います。
※ Sampleの方を実行してください。
※ 既にSheet2に〇印等があっても、追加するだけの処理になっています。
　（繰り返し実行すると、同じ位置に〇が追加されます）
※ 画像がよく見えないので、セル位置などがずれているかも知れませんが悪しからず。
※ 丸の付け方はご提示のコードにならっていますが、セルサイズ依存なので不揃いになり、これも変ではないかとは思いますが・・・


Sub Sample()
chekAndMaru "A2", "男,女", "A2:A3"
chekAndMaru "B6", "満足,普通,不満", "B7:D7"
chekAndMaru "B8", "満足,普通,不満", "B9:D9"
End Sub

Sub chekAndMaru(s1, s2, s3)
Dim s, i As Long, v As String
Dim c As Range, r As Double
v = Worksheets("Sheet1").Range(s1).Text
s = Split(s2, ",")
For i = 0 To UBound(s)
If s(i) = v Then
Set c = Worksheets("Sheet2").Range(s3)(i + 1).MergeArea
r = Application.Min(c.Width, c.Height) - 1.5
With Worksheets("Sheet2").Shapes.AddShape(msoShapeOval, _
c.Left + (c.Width - r) / 2, c.Top + (c.Height - r) / 2, r, r)
.Fill.Visible = False
.Line.Visible = True
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Transparency = 0
.Line.Weight = 1.5
End With
Exit Sub
End If
Next i
End Sub

この回答へのお礼

ありがとうございます。思った通りに〇印をつけることができました。
小職が添付した表が間違っており実際は、「満足」「普通」「不満足」の文字が入っておりそれを消せないため〇印を描く表になっておりました。
内容の理解に時間がかかるますが内容把握できるよう調べてみます。
お世話になりました。

お礼日時：2022/11/08 20:05

No.1 回答者： くんこば 回答日時： 2022/11/08 15:42

ステップ実行するか、プログラムを小さくしながら実行。

この程度、人に頼らなくてもできる。

この回答へのお礼

アドバイスありがとうございます。

お礼日時：2022/11/08 20:05