エクセルでセルをクリックしてカウンターもどきにする(1)

EXCELでカウンターのように、ボタンをクリックすると数字が[1、2、3、4・・・]と...
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1210789317

上のような動作をさせたくなりました。でもボタンやスピンボタンをおくと印刷したときに邪魔だし、スピンボタンだと100マスぐらいあるとちっさくてボタンが押せないのでどうにかしようとあがいてみました。

EXCEL(VBA) セルをクリックしたときの処理
http://oshiete.goo.ne.jp/qa/345340.html

>シートをクリックしただけで発生するイベントは無いのではないでしょうか
> 多少強引なやりかたとしては、次のような方法もあるにはあります。
>(1)セルと同じ大きさテキストなしのラベルを貼り付け、それぞれにマクロを登録する
>(2)登録したマクロのプロシージャ内で、クリックされたオートシェープの名前等により
> クリックされたことにするセルを判断する
>(3)マクロプロシージャ内にセルのselectメソッドを書いておけば、
>SelectionChangeイベントではキーボードによるセル移動などにも反応してしまったり、
>現在選択されているセルをクリックしても反応しないという問題があります

#標準モジュール
'**************************************************
'選択したセルに順序を書き込む関数
'http://www.k1simplify.com/vba/tipsleaf/leaf22.html
'**************************************************
Sub Test1()
Dim LoopArea As Range
Set LoopArea = Selection
For i = 1 To LoopArea.Count
LoopArea.Cells(i).Value = i
Next
End Sub


#標準モジュール
'***********************************************
'選択したセルにセルの名前(A1 とか)を書き込む関数
'http://home.att.ne.jp/zeta/gen/excel/c04p54.htm
'***********************************************
Sub Test2()
Dim LoopArea As Range
Set LoopArea = Selection
For i = 1 To LoopArea.Count
With LoopArea.Cells(i)
.Value = .Address(RowAbsolute:=False, ColumnAbsolute:=False)
End With
Next
End Sub


■ 調べもの ■
[excel][vba]枠線だけのオートシェイプを作るマクロ その1
http://blog.livedoor.jp/qoozy/archives/52556504.html

エクセルVBAで角丸四角形のオートシェイプを作成 msoShapeRoundedRectangle
http://www.excel-excel.com/tips/shape/shp_133.html

#標準モジュール
'****************************************************
'選択範囲のサイズで四角形を作成する関数
'http://www.excel-excel.com/tips/shape/shp_133.html
'http://blog.livedoor.jp/qoozy/archives/52556504.html
'****************************************************
Sub Test3()
Dim lType As String
Dim lShape As Shape

lType = msoShapeRectangle
'四角 msoShapeRectangle
'角丸四角形 msoShapeRoundedRectangle
'円 msoShapeOval
With Selection
Set lShape = ActiveSheet.Shapes.AddShape(Type:=lType, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
lShape.Name = "シェイプRoundedRectangle"
End With
Set lShape = Nothing
End Sub


#標準モジュール
'****************************************************
'選択範囲のサイズで枠だけの四角形を作成する関数
'(わかりにくいのでちょっと内側+うっすら色つき)
'http://www.excel-excel.com/tips/shape/shp_133.html
'http://blog.livedoor.jp/qoozy/archives/52556504.html
'****************************************************
Sub Test4()
Dim lType As String
Dim lShape As Shape

lType = msoShapeRectangle
'四角 msoShapeRectangle
'角丸四角形 msoShapeRoundedRectangle
'円 msoShapeOval
With Selection
Set lShape = ActiveSheet.Shapes.AddShape(Type:=lType, _
Left:=.Left + 1, Top:=.Top + 1, Width:=.Width - 2, Height:=.Height - 2)
lShape.Name = "シェイプRoundedRectangle"
End With

lShape.Select

'塗りつぶしの設定
With Selection.ShapeRange.Fill
'.Visible = msoFalse '塗りつぶしの有無
.Visible = msoTrue '塗りつぶしの有無
.ForeColor.RGB = RGB(255, 0, 255) '塗りつぶしの色
.Transparency = 0.9 '塗りつぶしの透明度
End With
'線の設定
With Selection.ShapeRange.Line
.Visible = msoTrue '線の有無)
.Style = msoLineSingle '線の種類(実線)
.ForeColor.RGB = RGB(0, 0, 0) '線の色
.Transparency = 0 '線の透明度
.Weight = 1 '線の太さ
End With

Set lShape = Nothing
End Sub


■ 調べもの ■
Excel VBAでオートシェイプに登録したマクロ名を取得する
http://blog.ch3cooh.jp/entry/20081121/1357113549

OnActionのマクロに引数を渡す方法と、それActionControlプロパティで出来るよ!ってお話
http://d.hatena.ne.jp/so_blue/20101116/1289918205

Shape.OnAction プロパティ (Excel)
http://msdn.microsoft.com/ja-jp/library/office/ff834436(v=office.15).aspx

マクロ付きShapeオブジェクトでどれが呼び出したかを知る
http://blogs.yahoo.co.jp/chika_z/1036381.html

Office TANAKA - Excel VBAステートメント[On Errorステートメント]
http://officetanaka.net/excel/vba/statement/OnError.htm

#標準モジュール
'*************************************************
'選択範囲のサイズで四角形を作成してマクロを設定
'http://d.hatena.ne.jp/so_blue/20101116/1289918205
'*************************************************
Sub Test5()
Dim lType As String
Dim lShape As Shape

lType = msoShapeRectangle
With Selection
Set lShape = ActiveSheet.Shapes.AddShape(Type:=lType, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
lShape.Name = "シェイプRoundedRectangle"
lShape.OnAction = "Test5a"
End With
Set lShape = Nothing
End Sub

Sub Test5a()
MsgBox "テスト"
End Sub


#標準モジュール
'****************************************************
'選択範囲のサイズで四角形を作成してましなマクロを設定
'http://blogs.yahoo.co.jp/chika_z/1036381.html
'****************************************************
Sub Test6()
Dim lType As String
Dim lShape As Shape

lType = msoShapeRectangle
With Selection
Set lShape = ActiveSheet.Shapes.AddShape(Type:=lType, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
lShape.Name = "シェイプRoundedRectangle"
lShape.OnAction = "Test6a"
End With
Set lShape = Nothing
End Sub

Sub Test6a()
Dim lShape As Shape
On Error Resume Next
Set lShape = ActiveSheet.Shapes(Application.Caller)
MsgBox lShape.Name
End Sub


#標準モジュール
'**********************************************************************
'選択範囲の各セルと重なる四角形を作成してセル名称を表示するマクロを設定
'**********************************************************************
Sub Test7()
Dim LoopArea As Range
Dim lShape As Shape

Set LoopArea = Selection
For i = 1 To LoopArea.Count
With LoopArea.Cells(i)
Set lShape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
lShape.Name = .Address(RowAbsolute:=False, ColumnAbsolute:=False)
lShape.OnAction = "Test7a"

lShape.Select

With Selection.ShapeRange.Fill
.Visible = msoTrue '塗りつぶしの有無
.ForeColor.RGB = RGB(255, 0, 255) '塗りつぶしの色
.Transparency = 0.9 '塗りつぶしの透明度
End With
Selection.ShapeRange.Line.Visible = msoFalse

Set lShape = Nothing
End With
Next
End Sub

Sub Test7a()
Dim lShape As Shape
On Error Resume Next
Set lShape = ActiveSheet.Shapes(Application.Caller)
MsgBox lShape.Name
End Sub


■ 調べもの ■
12.3 ワークシート上のオートシェイプ(図形)を削除する
http://www.happy2-island.com/excelsmile/smile03/capter01203.shtml

'*****************************************************************
'自分以外のすべてのシェイプを削除する
'http://www.happy2-island.com/excelsmile/smile03/capter01203.shtml
'*****************************************************************
Sub Test8()
Dim i As Long
i = 1
Do Until i > ActiveSheet.Shapes.Count
With ActiveSheet
If .Shapes(i) Is .Shapes(Application.Caller) Then
i = i + 1
Else
.Shapes(i).Delete
End If
End With
Loop
End Sub

'**********************************************************************
'既存のシェイプを全部削除して、選択範囲の各セルと重なる四角形を作成して
'四角形にはセルの名前(A1 とか)を設定しておいて、クリックしたときに
'そのセル名称を使っていろいろするマクロを設定
'**********************************************************************
Sub Test9()
Dim i As Long
i = 1
Do Until i > ActiveSheet.Shapes.Count
With ActiveSheet
If .Shapes(i) Is .Shapes(Application.Caller) Then
i = i + 1
Else
.Shapes(i).Delete
End If
End With
Loop

Dim LoopArea As Range
Dim lShape As Shape

Set LoopArea = Selection
For i = 1 To LoopArea.Count
With LoopArea.Cells(i)
Set lShape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
lShape.Name = .Address(RowAbsolute:=False, ColumnAbsolute:=False)

lShape.Select

With Selection.ShapeRange.Fill
.Visible = msoTrue '塗りつぶしの有無
.ForeColor.RGB = RGB(255, 0, 255) '塗りつぶしの色
.Transparency = 0.9 '塗りつぶしの透明度
End With
Selection.ShapeRange.Line.Visible = msoFalse

lShape.OnAction = "Test9a"
Set lShape = Nothing
End With
Next
End Sub

'----------------------------------
'シェイプの置いてあるセルを選択する
'----------------------------------
Sub Test9a()
Dim lShape As Shape
On Error Resume Next
Set lShape = ActiveSheet.Shapes(Application.Caller)
ActiveSheet.Range(lShape.Name).Select
End Sub

'****************************************************************
'既存のシェイプを全部削除
'選択範囲の各セルと重なる四角形を作成
'選択範囲のセルの内容をクリア
'四角形にはセルの名前(A1 とか)を設定
'作成した四角形をクリックしたときにセルの名前を使ってセルの内容を
'書き換えるマクロを設定
'****************************************************************
Sub Test10()
Dim i As Long
i = 1
Do Until i > ActiveSheet.Shapes.Count
With ActiveSheet
If .Shapes(i) Is .Shapes(Application.Caller) Then
i = i + 1
Else
.Shapes(i).Delete
End If
End With
Loop

Dim LoopArea As Range
Dim lShape As Shape

Set LoopArea = Selection
For i = 1 To LoopArea.Count
With LoopArea.Cells(i)
.Value = ""
Set lShape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
lShape.Name = .Address(RowAbsolute:=False, ColumnAbsolute:=False)

lShape.Select

With Selection.ShapeRange.Fill
.Visible = msoTrue '塗りつぶしの有無
.ForeColor.RGB = RGB(255, 0, 255) '塗りつぶしの色
.Transparency = 0.9 '塗りつぶしの透明度
End With
Selection.ShapeRange.Line.Visible = msoFalse

lShape.OnAction = "Test10a"
Set lShape = Nothing
End With
Next
End Sub

'----------------------------------------
'シェイプの置いてあるセルをカウントアップ
'----------------------------------------
Sub Test10a()
Dim lShape As Shape
On Error Resume Next
Set lShape = ActiveSheet.Shapes(Application.Caller)
With ActiveSheet.Range(lShape.Name)
.Value = .Value + 1
.Select
End With
End Sub


一応動くことは動くけれども、クリアするときにすでに作成済みのオートシェイプが
全面に敷き詰めてあるので、「選択範囲のセルを~」の部分が邪魔をして若干面倒くさい。

一度、どうでもいいセルを選択した状態でクリアしておいてから~みたいない気持ちの
悪いことをする必要がありました。気持ち悪い。


■ 調べもの ■
ハイパーリンクのクリックでマクロを実行する
http://www.excel-wing.com/study/jitumu/941

これちょっといい感じかも。
関連記事
スポンサーサイト