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ベストアンサー
- 回答日時:
こんにちは
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
ありがとうございます。思った通りに〇印をつけることができました。
小職が添付した表が間違っており実際は、「満足」「普通」「不満足」の文字が入っておりそれを消せないため〇印を描く表になっておりました。
内容の理解に時間がかかるますが内容把握できるよう調べてみます。
お世話になりました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- PowerPoint(パワーポイント) ExcelのVBAコードについて教えてください。 3 2022/05/25 14:32
- Visual Basic(VBA) エクセルVBAで教えて頂きたいのですが? 2 2022/12/31 20:28
- Visual Basic(VBA) 動きっぱなしです。止め方とプロシージャの間違いを教えて下さい! 5 2022/08/15 23:08
- Visual Basic(VBA) Excel vbaについての質問 3 2023/04/18 16:14
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Excel(エクセル) 日付で矢印マクロ 4 2023/07/25 16:47
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) VBAの繰り返し処理について教えてください。 3 2022/08/02 13:21
- Excel(エクセル) エクセルで同じ数字同士を自動で線で結ぶVBAを教えてください 6 2022/04/26 23:13
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VBA指定行削除
-
B列の最終行までA列をオート...
-
VBAで10行おきにセルの下に罫線...
-
Cellsのかっこの中はどっちが行...
-
VBAで指定範囲内の空白セルを左...
-
rowsとcolsの意味
-
VBAの初心者なのですが、「並び...
-
Excel VBA 足し算の問題を自動...
-
Excel VBA の件で質問です
-
難問 VBA 今日の日付より前に対...
-
空文字 "" ですが 空文字の意味...
-
エクセルについて
-
エクセル VBA 条件にあうセルの...
-
VBAを使って検索したセルをコピ...
-
VBAのFind関数で結合セルを検索...
-
グリッドの列の最大値を求めたい。
-
エクセルVBAにて =A1=B1とすれ...
-
マクロ 最終列をコピーして最終...
-
【補足欄が足りなかったため、...
-
エクセルVBAで複数の条件を満た...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Worksheets メソッドは失敗しま...
-
Excelで、あるセルの値に応じて...
-
B列の最終行までA列をオート...
-
vba 2つの条件が一致したら...
-
Cellsのかっこの中はどっちが行...
-
VBAを使って検索したセルをコピ...
-
文字列の結合を空白行まで実行
-
VBAのFind関数で結合セルを検索...
-
IIF関数の使い方
-
【VBA】2つのシートの値を比較...
-
マクロ 最終列をコピーして最終...
-
VBA 何かしら文字が入っていたら
-
Changeイベントでの複数セルの...
-
URLのリンク切れをマクロを使っ...
-
エクセルVBAにて =A1=B1とすれ...
-
VBAでのリスト不一致抽出について
-
データグリッドビューの一番最...
-
マクロについて。S列の途中から...
-
VBA UserFormからの転記で
-
targetをA列のセルに限定するに...
おすすめ情報