エクセルVBAでもっとすっきりさせたい

質問

エクセル2000です。
ワークシート上にオートシェープの楕円を５個配置してあります。
それぞれ名前をOval_1～Oval_5と設定しました。
それぞれは以下のマクロを組み込み、クリックにより破線、実線と変更します。実線が選択されたしるしとします。
Oval_1～Oval_3で１グループ、Oval_4～Oval_5で１グループとし、それぞれのグループ内で1個の楕円しか選べないようにしたいのです。

一応、希望通りの動きはするのですが、何かすっきりしません。
もっと気の利いたコードはないでしょうか？

Sub Oval_Check()

With ActiveSheet
If .Shapes(Application.Caller).Line.DashStyle = msoLineSolid Then 'クリックしたのが実線なら
.Shapes(Application.Caller).Line.DashStyle = msoLineSquareDot ' 破線に

Select Case Application.Caller 'クリックしたのが
Case "Oval_4" 'Oval_4なら
.Shapes("Oval_5").Line.DashStyle = msoLineSolid 'Oval_5を実線に
Case "Oval_5" 'Oval_5なら
.Shapes("Oval_4").Line.DashStyle = msoLineSolid 'Oval_4を実線に
End Select

Else 'そうでないなら
.Shapes(Application.Caller).Line.DashStyle = msoLineSolid ' 実線に

Select Case Application.Caller 'クリックしたのが
Case "Oval_1" 'Oval_1なら
.Shapes.Range(Array("Oval_2", "Oval_3")).Line.DashStyle = msoLineSquareDot 'Oval_2,Oval_3を破線に
Case "Oval_2" 'Oval_2なら
.Shapes.Range(Array("Oval_1", "Oval_3")).Line.DashStyle = msoLineSquareDot 'Oval_1,Oval_3を破線に
Case "Oval_3" 'Oval_3なら
.Shapes.Range(Array("Oval_1", "Oval_2")).Line.DashStyle = msoLineSquareDot 'Oval_1,Oval_2を破線に

Case "Oval_4" 'Oval_4なら
.Shapes("Oval_5").Line.DashStyle = msoLineSquareDot 'Oval_5を破線に
Case "Oval_5" 'Oval_5なら
.Shapes("Oval_4").Line.DashStyle = msoLineSquareDot 'Oval_4を破線に
End Select

End If
End With
End Sub

回答No.2

xls88 · ベストアンサー

こんな風にまとめてみました。

Sub Oval_Check()
　　Dim ov1 As String, ov2 As String, ov3 As String
　　Dim ov4 As String, ov5 As String
　　Dim ov As String
　　Dim ova As Variant, ovb As Variant

　　ov1 = "Oval_1": ov2 = "Oval_2": ov3 = "Oval_3"
　　ov4 = "Oval_4": ov5 = "Oval_5"

　　With ActiveSheet.Shapes
　　　　ov = Application.Caller 'クリックした図形の
　　　　' 線の種類を取得
　　　　Select Case .Range(ov).Line.DashStyle '線の種類が
　　　　Case msoLineSolid　　 '実線の場合
　　　　　　ova = msoLineSolid
　　　　　　ovb = msoLineSquareDot
　　　　Case msoLineSquareDot '点線の場合
　　　　　　ova = msoLineSquareDot
　　　　　　ovb = msoLineSolid
　　　　End Select
　　　　' 線の種類を変更
　　　　Select Case ov　　　　 'クリックした図形が
　　　　Case ov1, ov2, ov3　　 'の場合
　　　　　　.Range(Array(ov1, ov2, ov3)).Line.DashStyle = ova
　　　　Case ov4, ov5　　　　 'の場合
　　　　　　.Range(Array(ov4, ov5)).Line.DashStyle = ova
　　　　End Select
　　　　.Range(ov).Line.DashStyle = ovb
　　End With
End Sub

お礼

ありがとうございます。
とても参考になりました。
ただ、Oval_1～Oval_3で三択、Oval_4～Oval_5で二択なのですが、ご教示のものではOval_1～Oval_3の三択の部分で、実線（選択された状態）の楕円をクリックし、破線に変えると残る２つが実線に変わってしまい、三択になりません。

回答No.8

xls88

＞回答番号：No.7 この回答へのお礼

>For Each sp In ActiveSheet.Shapes
>MsgBox sp.Name
>Next
>とやってみたところ、出てくるのはグループ名のみで、

GroupItemsプロパティを使えば、多分Excel2000でも、Group内の個々の図形に処理ができるようです。
あるいは(無意味かも知れませんが)、一旦Group化を解除して処理を実行後、再グループ化する手があると思います。

TypeName関数 とか、Typeプロパティを使って、戻り値でGroup化されているかどうか判定し、処理を分岐すれば良いとおもいます。

お礼

ありがとうございます。
やはり大変そうですね。
勉強してみます。

回答No.7

xls88

Group化した図形、単独でGroupの図形、単独図形、が混在する場合に対応してみました。

前提条件として、
図形に、「A-1、A-2、A-3」、「B-1、B-2」のようにグループ分けが容易な名前を付ける。
というように考えています。

グループに属さない、単独の図形の場合は、実線と破線に交互に切り替えるようにしています。

Sub test3()
　　Dim shp As Object
　　Dim sn As String
　　Dim ov As String
　　Dim dsh As Long
　　Dim i As Long
　　Dim n As Long

　　ov = Application.Caller 'クリックされた図形
　　sn = Split(ov, "_")(0)
　　dsh = ActiveSheet.Shapes.Range(ov).Line.DashStyle
　　For Each shp In ActiveSheet.Shapes
　　　　On Error Resume Next
　　　　n = shp.GroupItems.Count
　　　　On Error GoTo 0
　　　　If n <> 0 Then
　　　　　　For i = 1 To n
　　　　　　　　If shp.GroupItems(i).Name Like sn & "*" Then
　　　　　　　　　　shp.Line.DashStyle = msoLineSquareDot
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next i
　　　　ElseIf n = 0 Then
　　　　　　If shp.Name <> ov And shp.Name Like sn & "*" Then
　　　　　　　　shp.Line.DashStyle = msoLineSquareDot
　　　　　　End If
　　　　End If
　　　　n = 0
　　Next
　　With ActiveSheet.Shapes.Range(ov)
　　　　Select Case dsh
　　　　Case msoLineSquareDot: .Line.DashStyle = msoLineSolid
　　　　Case msoLineSolid: .Line.DashStyle = msoLineSquareDot
　　　　End Select
　　End With
End Sub

お礼

明けましておめでとうございます。
お正月休みでお返事が遅くなり申し訳ございませんでした。
何度もありがとうございます。
グループ化しての方法、とても興味があります。
ただ、わたしのエクセル２０００だと、

回答番号：No.6
ActiveSheet.Shapes.Range(ov).Line.DashStyle = msoLineSolid
回答番号：No.7
dsh = ActiveSheet.Shapes.Range(ov).Line.DashStyle

が実行時エラー1004「指定した名前のアイテムがみつかりませんでした」となってしまいます。
ためしに
For Each sp In ActiveSheet.Shapes
MsgBox sp.Name
Next
とやってみたところ、出てくるのはグループ名のみで、グループ化された個々のオブジェクトはとらえられないようです。

回答No.6

xls88

こんな風になりました。
対象図形が、グループ化されていることが前提条件です。
取りあえず、For～Nextしています。
クリックされた図形が属する、Groupを、もっと簡単に特定できる方法を探しています。

Sub test1()
　　Dim ov As String
　　Dim myf As Boolean
　　Dim i As Long
　　Dim j As Long
　　Dim n As Long
　　ov = Application.Caller
　　For i = 1 To ActiveSheet.Shapes.Count
　　　　myf = False
　　　　With ActiveSheet.Shapes(i)
　　　　　　On Error Resume Next
　　　　　　n = .GroupItems.Count
　　　　　　On Error GoTo 0
　　　　　　If n >= 2 Then
　　　　　　　　For j = 1 To .GroupItems.Count
　　　　　　　　　　If .GroupItems(j).Name = ov Then
　　　　　　　　　　　　.Line.DashStyle = msoLineSquareDot
　　　　　　　　　　　　myf = True
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　　　If myf = True Then Exit For
　　　　　　End If
　　　　End With
　　　　n = 0
　　Next i
　　ActiveSheet.Shapes.Range(ov).Line.DashStyle = msoLineSolid
End Sub

回答No.5

Wendy02

こんにちは。

>おっしゃるとおり本来はオプションボタンで対応すべきことなのです。

私は、そういうように考えているのではなく、コードの標準化です。
クラス・インスタンスも考えたのですが、グループ別けのプロパティを加えることができないように思いました。もしかしたら、可能かもしれませんが、簡単な方法を選びました。

#1さん曰く
>プログラムは貴方のソースコードのように
>ベタ書きになってしまい、設問が100個もあると、ソースコードは
>600～1000行ぐらいにはなるのでは？と思います。

に呼応して、コードを書いたまでです。

オプションボタンの仕様を借りれば、設問が増えても、コードは増えないです。ご質問のコードでは、設問が増えれば、どんどん書き加えなくてはならないはずです。そういうことは問題ではなさそうですね。

#2さんのコードも、ただ、1行を加えればよいだけですよね。

お礼

明けましておめでとうございます。
お正月でお返事が遅くなり申し訳ございませんでした。

今回は対象数が少ないので問題はありませんでしたが、多くなった場合のために勉強させていただきます。
いつも為になるご指導をいただきありがとうございます。

回答No.4

xls88

> Oval_1～Oval_3で１グループ、Oval_4～Oval_5で１グループとし、
> それぞれのグループ内で1個の楕円しか選べないようにしたいのです。
上記、仕様に沿っていると思います。
オリジナルのコードとも、同じ動作になっています。
どうなって欲しいのですか？

制約は設けていませんので、御気に召すよう改編改修していただいて結構ですよ。

お礼

何度もありがとうございます。
.Range(Array(ov1, ov2, ov3)).Line.DashStyle = ova
　の部分で、実線の楕円をクリックするとその楕円が破線になり、残りの２つが実線となってしまいます。わたしの書き方が悪いのですが「1個の楕円しか選べないように」の意味はグループ内で１個の楕円しか実線にならないようにの意味です。

でもNo3のお礼に書いたコードでうまくいきました。
ありがとうございました。

回答No.3

Wendy02

こんにちは。

>Oval_1～Oval_3で１グループ、Oval_4～Oval_5で１グループとし、それぞれのグループ内で1個の楕円しか選べないようにしたいのです。

ご質問の内容って、OptionButton の働きがあればよいのではありませんか？

OptionButton をオートシェイプの数（枝番をあわせます）だけ、シートの片隅に作って、グループ名で分ければよいと思います。気の利いているのかは判りませんが、難しく考える必要もありませんね。

いくら、丸の数が増えても、オプションボタン側で設定すればよいので、以下のマクロは変わりません。

OnAction に、手動でマクロを付けるのは面倒なので、設定用のマクロを設けました。

理屈は、ひとつのオートシェイプ側から、オプションボタンを設定して、後は、逆にオプションボタンから、全てのオートシェイプを反映させます。

注意：OptionButtonのプロパティのグループ名を、きちんと分けてください。
例　Sheet1 -> Group1, Group2, Group3
あまり、数が多いようなら、グループ名だけで分岐してもよいと思います。

'標準モジュール（シートモジュールなら、ActiveSheet は、Meキーワード）

Sub SetOnAction()
'設定用
Dim shp As Variant
For Each shp In ActiveSheet.Shapes
　If shp.Name Like "Oval_#*" Then
　 shp.OnAction = "Oval_Op"
　End If
Next shp
End Sub

'-----------------------------------------
Sub Oval_Op()
　　Dim i As Variant
　　Dim j As Integer
　　Dim nshp As String
　　Dim grp As String
　　i = Replace(Application.Caller, "Oval_", "")
　　If VarType(Application.Caller) = vbString Then
　　　 nshp = Application.Caller
　　Else
　　　 Exit Sub
　　End If
　　With ActiveSheet　'Me
　　If IsNumeric(i) Then
　　　 chgLineStyle nshp, i
　　End If
　　End With
End Sub
Sub chgLineStyle(nshp As String, i As Variant)
Dim j As Integer
Dim shp as Variant
　　With ActiveSheet　'Me
　　　　If .OLEObjects("OptionButton" & i).Object.Value = False Then
　　　　　　.Shapes(nshp).Line.DashStyle = 1
　　　　　　.OLEObjects("OptionButton" & i).Object.Value = True
　　　　End If
　　　　For Each shp In .Shapes
　　　　　　If shp.Name Like "Oval_#*" Then
　　　　　　　　j = Replace(shp.Name, "Oval_", "")
　　　　　　　　If .OLEObjects("OptionButton" & j).Object.Value Then
　　　　　　　　　　.Shapes(shp.Name).Line.DashStyle = 1
　　　　　　　　Else
　　　　　　　　　　.Shapes(shp.Name).Line.DashStyle = 2
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
End Sub

お礼

ありがとうございます。おっしゃるとおり本来はオプションボタンで対応すべきことなのです。しかし、No1さんのお礼にも書きましたようにクリックした箇所の破線のマルを実線のマルにビジュアルに変えることが必要なのです。でもよく考えると本来のオプションボタンならすでにオンのものをクリックしても変化しませんよね。なら楕円だってそうすればいいわけで、実線の楕円をクリックしたらExitするようにしたらすっきりしました。

Sub Oval_Check()
Dim ov As String
With ActiveSheet
ov = Application.Caller
If .Shapes(ov).Line.DashStyle = msoLineSolid Then 'クリックしたのが実線なら
Exit Sub '終了
Else '破線なら
Select Case ov 'クリックしたのが
Case "Oval_1", "Oval_2", "Oval_3" 'Oval_1～3なら
.Shapes.Range(Array("Oval_1", "Oval_2", "Oval_3")).Line.DashStyle = msoLineSquareDot 'Oval_1～3を破線に
Case "Oval_4", "Oval_5" 'Oval_4～5なら
.Shapes.Range(Array("Oval_4", "Oval_5")).Line.DashStyle = msoLineSquareDot 'Oval_4～5を破線に
End Select
.Shapes(ov).Line.DashStyle = msoLineSolid 'クリックしたのを実線に
End If
End With
End Sub

回答No.1

noname#245936

なんとなく。

Excelでビジュアルなアンケート用紙みたいなものを作りたい？
…と察しますが。

Excelで画面制御バリバリの固定入力フォームを作るとなると、
ツール的にしんどい面があるかな？と思います。
特にShapeを使うと見た目は綺麗ですが、効率的に使えるセル座標系
関数が全く使えないので、プログラムは貴方のソースコードのように
ベタ書きになってしまい、設問が100個もあると、ソースコードは
600～1000行ぐらいにはなるのでは？と思います。

また、この設問シートが多人数に配布され、あとで集計されるもので
あれば、集計は人間の手作業になりしんどいことになると思います。

もし、しっくりしない点が以上のようなことであれば。
どうしても、Excelを使うならば、一つの方法は、設問と入力場所を
変えることとExcelセル関数で片付けてしまうこと。

例えば、貴方の設問には
・グループ選択肢
・ON / OFF
・自由入力
の３要素がありますが。

提示画像のShapeのある位置に、=IF(Ax=1,"1","(1)")のような関数を
埋めて、右の方の別セルに回答欄を持ってくる。
その回答欄Ax座標に「１」が入っていれば(1)、それ以外は1と表示
するようにする。
マクロでチェックさせるなら、回答のチェックボタンを作成し、
回答欄Ax座標の論理解釈とErrorメッセージを表示…としてしまう。
そうすると、回答欄列のみ別シートへコピペすると、集計は適当な
セル関数で可能です。
（ま、強引にShape名をString関連の関数とVBでゴソゴソ捏ねるのも
　いいのですけど。）

もしくは。
そもそも違うツールを使ってしまう。
FileMakerやAccessあたりで組んでしまう方が早いかもしれません。

Excelはあくまで、対セルに対する参照系関数が第一の醍醐味で。
VBAはその論理的解析や結果に対する制御に向くので、
UIの完全制御を求めると膨大なコード量を必要としたり、変更に
弱かったり、いろいろ手数は要ると思います。

とはいえ、やってみることは大事なことなので。
いいチャレンジだとは思います。

私も入門当時はExcelマクロでしたので。

お礼

今回のはアンケート用紙のような集計を目的とするものではなく、本来ならオプションボタンを用いるところを、クリックした箇所の破線のマルを実線のマルにビジュアルに変えることが必要なのです。
でも、貴重なご意見とても勉強になりました。
ありがとうございます。