図形描画を作成ボタンを作成するには？

質問

エクセルで表を作成しています。
ある状態を監視し、その状態を図形描画の「→」（矢印）を利用して平行、傾き右斜め下向き、右斜め上向きの３つの矢印で状態を表すようにしています。
この時、一度作成した図形があるセルをコピーして貼り付けていますが、
マクロ（？）などで、ボタンを３つ作成して簡単に矢印を該当セルに作成すること方法はありませんか？
質問が支離滅裂ですみません。

回答No.4

nishi6 · ベストアンサー

やっと、回答したコードをExcel97で実行できました。特に問題なく動きました・・・

確認ですが、回答に書いた、

『Sheet1に平行、傾き右斜め下向き、右斜め上向きの矢印を書きます。
　この３つの矢印に名前ボックス（シート左上）を使って、
　平行な矢印に『LineEv』、右斜め上向きに『LineUp』、下向きに『LineDw』の名前をつけます。 』

は、各ボタンと図形を関連付けるために、登録の意味合いで、どこか変更しない位置に３種類の矢印を書いて名前を付けます。
まず、３種の矢印に指定した名前がついているか確認して下さい。
使い方としては、別の矢印を書きたいセルを選択してボタンを押せば、ボタンに対応した矢印が出ます。これは別のボタンを押せば変更できます。
コピーとか貼り付けの処理はしません。

補足によると、シートが毎月、追加（変更）されるようなので、シートに関係しない方法を考えてみました。
また、図形の矢印ではなく、全角の『→』を使って、水平、右上向き、右下向き矢印を書いています。
コードの『45、-45』を変更すれば角度が指定できます。
ツールバーを作っているので、シートに関係なく使用できます。ご参考に。

標準モジュールに貼りつけます。
コマンドバーのアイコンは適当なものがなかったので、水平と上・下矢印にしてあります。
CommandBar_ArrowButtonでコマンドバーを追加
CommandBar_ArrowButtonDelでコマンドバーを削除します。

ここから
↓
'コマンドバー『矢印ボタン』を追加
Sub CommandBar_ArrowButton()
　　Dim myBar As CommandBar 'コマンドバー
　　Dim myControl(1 To 3) As CommandBarControl 'コマンドバー内のコマンドボタン
　　Dim i As Integer 'カウンタ

　　On Error Resume Next
　　CommandBars("矢印ボタン").Delete 'コマンドバーの名前を『矢印ボタン』とする
　　On Error GoTo 0

　　Set myBar = CommandBars.Add(Name:="矢印ボタン", Position:=msoBarFloating, Temporary:=True)
　　With myBar
　　　　.Protection = msoBarNoChangeDock
　　　　.Left = 50
　　　　.Top = 100
　　End With

　　'コマンドバーにボタンを作る
　　For i = 1 To 3
　　　　Set myControl(i) = myBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
　　　　With myControl(i)
　　　　　　Select Case i
　　　　　　　　Case 1: .TooltipText = "水平矢印です。"
　　　　　　　　　　　　.FaceId = 1142
　　　　　　　　Case 2: .TooltipText = "右上向き矢印です。"
　　　　　　　　　　　　.FaceId = 1144
　　　　　　　　Case 3: .TooltipText = "右下向き矢印です。"
　　　　　　　　　　　　.FaceId = 1145
　　　　　　End Select
　　　　　　.OnAction = "'ArrowDrow " & i & "'" 'マクロを割り当て
　　　　End With
　　Next
　　myBar.Visible = True
End Sub

'文字の『→』を傾きをつけて書く
Sub ArrowDrow(Kubun As Integer)
　　Dim rg As Range 'セル
　　Dim ortSet As Long '文字の傾き
　　Dim rwHeight As Long '最初のセルの高さ

　　Select Case Kubun
　　　　Case 1: ortSet = 0 '水平
　　　　Case 2: ortSet = 45 '右上向き
　　　　Case 3: ortSet = -45 '右下向き
　　End Select

　　Application.ScreenUpdating = False
　　'複数セルを選択している場合の対応
　　For Each rg In Selection
　　　　rg = "→"
　　　　With rg
　　　　　　rwHeight = .RowHeight 'セルの高さを退避
　　　　　　.Orientation = ortSet '文字の傾き
　　　　　　.HorizontalAlignment = xlCenter '水平位置で中央
　　　　　　.VerticalAlignment = xlCenter '垂直位置で中央
　　　　　　.RowHeight = rwHeight 'セルの高さを最初と同じにする
　　　　End With
　　Next
　　Application.ScreenUpdating = True
End Sub

'コマンドバー『矢印ボタン』を削除
Sub CommandBar_ArrowButtonDel()
　　On Error Resume Next
　　CommandBars("矢印ボタン").Delete
　　On Error GoTo 0
End Sub

補足

早速、回答をいただきありがとうございます。
やはり、最初の図形を用いた方法では『→』が出てきませんでした。
シートに関係なく使用でできる方法を試そうと思うのですが、
ボタンはどのように作るのでしょうか？
１回目に記述した標準モジュールは消した方がいいんですよね？

当方、マクロについて全くの素人です。
要求しているシート作成について、最後までおつきあいいただければ助かります。

回答No.5

nishi6

＞ボタンはどのように作るのでしょうか？
＞１回目に記述した標準モジュールは消した方がいいんですよね？

出ないのは？ですね。では、図形を使わない方法です。
まず、新規ブックを開いて、それに対して行ってみます。

ツール→マクロ→Visual Basic Editor でVBE画面に移り、 挿入→標準モジュール で標準モジュールを挿入し、出てきたコードウインドウに#4のマクロをコピーして貼り付けます。 （#4の↓の下から全部）

シートに戻り、ツール→マクロ→マクロ で
　CommandBar_ArrowButton を実行すれば、コマンドバーを追加
　CommandBar_ArrowButtonDel を実行すれば、コマンドバーを削除します。

CommandBar_ArrowButtonを実行すれば、３つのボタンを持ったツールバーが、画面左上にできるはずです。
矢印を書くのにこのツールバーのボタンを使います。
　　セルを選択して、このコマンドバー内のボタンを押せば、ボタンに対応して
　　→、右上向き→、右下向き→がセルに書かれるはずです。

新規ブックで試して、同じ手順で、目的のブックにマクロを登録します。
その時は、不要なマクロは全て削除したおいたほうがいいでしょう。

お礼

最後までご丁寧に回答をいただきましてありがとうございました。

補足

懇切丁寧に回答していただきありがとうございます。
マクロを実行すればよかったのですね。

でもセルの罫線までもが傾いてしまうのはなぜでしょう。
隣のセルと結合すると問題ないのですが・・・。

それと質問を出してからNo.5の回答をいただくまでの間に
エクセルのバージョンを97から2000にあげたのですが、
97の人が矢印ボタンをクリックすると
エラーメッセージ「スタックが不足しています」というようなメッセージが出て
エクセルが強制終了してしまいます。
どなたかわかる方がいらしゃいましたらよろしくお願いします。

回答No.3

nishi6

Sheet1で行います。Sheet1にコントロールツールボックスのコマンドボタンを4つ作ります。

　CommandButton1　Captionは『－』　　 平行な矢印を書く機能
　CommandButton2　Captionは『Up』　　 右斜め上向き矢印を書く機能
　CommandButton3　Captionは『Down』　 右斜め下向き矢印を書く機能
　CommandButton4　Captionは『Del』　　選択したセルにある矢印を消去する機能にします。

選択したセルに既に別の矢印があったら書き換え、複数のセルを選択した時も機能させます。

Captionはコマンドボタンを右クリックしてプロパティを選択してプロパティウインドウを出して設定します。

Sheet1に平行、傾き右斜め下向き、右斜め上向きの矢印を書きます。
この３つの矢印に名前ボックス（シート左上）を使って、
　平行な矢印に『LineEv』、右斜め上向きに『LineUp』、下向きに『LineDw』の名前をつけます。

ツール→マクロ→Visual Basic Editor でVBE画面に移り、 表示→プロジェクトエクスプローラでプロジェクトエクスプローラを表示します。プロジェクトエクスプローラのSheet1をダブルクリック。出てきたコードウインドウに下記マクロをコピーして貼り付けます。

ここから 4つ目の End Sub まで
↓
Private Sub CommandButton1_Click()
　　ShapeDrow 0
End Sub

Private Sub CommandButton2_Click()
　　ShapeDrow 1
End Sub

Private Sub CommandButton3_Click()
　　ShapeDrow 2
End Sub

Private Sub CommandButton4_Click()
　　ShapeDrow 3
End Sub
↑
ここまで

次に、VBE画面で、挿入→標準モジュール で標準モジュールを挿入します。
出てきたコードウインドウに下記マクロをコピーして貼り付けます。

ここから End Sub まで
↓
Sub ShapeDrow(Kubun As Integer)
　　With Worksheets("Sheet1")
　　　　Select Case Kubun
　　　　　　Case 0: .Shapes("LineEv").Copy '平行
　　　　　　Case 1: .Shapes("LineUp").Copy '上向き
　　　　　　Case 2: .Shapes("LineDw").Copy '下向き
　　　　End Select
　　End With

　　Dim selArea As Range '選択範囲
　　Set selArea = Selection

　　Dim shp As Shape '図形
　　Dim rg As Range 'セル
　　'とりあえず選択範囲内の図形を消去する
　　For Each shp In Worksheets("Sheet1").Shapes
　　　　If Not Intersect(Range(shp.TopLeftCell.Address), selArea) Is Nothing Then
　　　　　　'選択範囲に図形のセルが含まれていれば削除する
　　　　　　shp.Delete
　　　　End If
　　Next

　　'消去する命令だったら処理を終わる
　　If Kubun = 3 Then Exit Sub

　　'選択範囲のセルに全て複写する
　　For Each rg In selArea
　　　　rg.Select
　　　　ActiveSheet.Paste
　　Next
　　selArea.Cells(1, 1).Select
End Sub
↑
ここまで

シートに戻って、デザインモードを解除します。
矢印を表示したいセルを選択して表示した矢印のボタンを押します。
セルは、単一、複数、Shift・Ctrlキーを使って選択できます。当方Excel2000です。

ご参考に。

補足

回答、ありがとうございます。
貴殿の回答通り、実施してみたのですが、矢印（矢線）を書くボタン『Ｕｐ』『Ｄｏｗｎ』等をクリックしても矢印（矢線）がコピーされず、既に書きこまれている矢印が消えてしまいます。
シートは月ごとに増やしていくので『Sheet1』ではなく、『02.06』とし、
該当するコマンドの『Sheet1』を『02.06』に置換しています。
（来月の作業ではこのシートをコピーしてシート名を『02.07』とします）
何か気づいた点があれば、教えていただければ幸いです。
当方のバージョンはExcel97です。

回答No.2

imogasi

こう言うことをしたいのではないのでしょうか。
質問の意味が良く掴めず、推定して答えています。
外れていたとしても、下記は参考になると思います。ぜひ
やって見てください。
データをＡ１からＢ７まで、例えば
1 4
2 1
4 3
5 6
6 2
3 6
4 2
と入力します。
ＶＢＥのＭｏｄｕｌｅ１に
Sub Ｔｅｓｔ01()
For i = 1 To 7
l = Cells(i, 3).Left
t = Cells(i, 3).Top
h = Cells(i, 3).Height
If Cells(i, 1) < Cells(i, 2) Then
Worksheets("Sheet1").Shapes.AddLine(l, t, l + 20, t + h).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
Selection.ShapeRange.Flip msoFlipVertical
Else
Worksheets("Sheet1").Shapes.AddLine(l, t + h, l + 20, t).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
Selection.ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
Selection.ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
Selection.ShapeRange.Flip msoFlipVertical
End If
Next i
End Sub
と入力し実行します。
Ａ列よりＢ列の数字が増えていれば、Ｃ列に上向き矢印、減っていればＣ列に下向き矢印をセットします。＝の時を今回は割愛しました。
一部マクロの自動記録を使っていますので、特徴が出ています。（Ｓｅｌｅｃｔｉｏｎの多出）ご免。

お礼

アドバイスありがとうございます。
矢印（矢線）は必ずしも数値で判断させるものではないので
求めているものと若干違いましたが、参考になりました。

回答No.1

misatoanna

お尋ねの内容を取り違えているかも知れませんが――
このようなことでよいのでしょうか？
---------------------------------------------
まず、「平行、右斜め上向き、右斜め下向き」の３つの矢印の図形を、それぞれ適当なフォルダに適当な名前で保存してください。
次に当該ブックを開き、[ツール]-[マクロ]-[VisualBasicEditor] で起動される画面から [挿入]-[標準モジュール] と進み、開いた編集画面に次のコマンドをコピーしてから、Editor を閉じてください。
'---- ここから ----------
Sub 水平矢印()
ActiveSheet.Pictures.Insert("aaaaa").Select
End Sub
Sub 上昇矢印()
ActiveSheet.Pictures.Insert("bbbbb").Select
End Sub
Sub 下降矢印()
ActiveSheet.Pictures.Insert("ccccc").Select
End Sub
'---- ここまで ----------
aaaaa、bbbbb、ccccc は、図形保存場所のフルパスに置き換えてください。
次に、ワークシートの一番上あたりの使っていないセルに、保存した３つの矢印の図形を呼び出して並べてください。
並べた図の中の「平行」を示す図形を右クリックして「マクロの登録」を選択し、表示されたボックスから「水平矢印」マクロを選択して[ＯＫ]。
他の２つについても同様の操作で、該当するマクロを選択します。
-------------------------------------------------
以上です。
あとは、矢印を描きたいセルをクリックしてから、マクロを割り当てた図形をクリックしてください。

補足

回答ありがとうございます。貴殿の回答にある、『平行、右斜め上向き、右斜め下向き」の３つの矢印の図形を、それぞれ適当なフォルダに適当な名前で保存』というのは、別のブック（エクセルファイル）に作成して保存することなのでしょうか？それとも、それぞれの矢印（矢線）を画像として保存させることなのでしょうか？コマンドをみると後者のほうと解釈できるのですが・・・・。