Excel VBA

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

前回作ったマクロを、実際に使ってみて反省点に対応しました。それなりに完成した気がします。
その1、その2で2種類作りましたが、結果的にシェイプを大量に貼り付けるバージョンを採用してます。

※※注意※※
シート状に存在しているオートシェイプ(四角形)を確認せずに削除するマクロを使っています。
マクロで作ったかどうかの判定はしてません。
マクロで作ったオートシェイプにはタグか何かに特殊な文字列でも書き込んでおいて削除時に判定すればいいのかも。

excelcounter20140524.zip

(1) ピンとこないサンプル画面ですみません。
まずは、いい感じに表を作ります。行にも列にも制限はないですけど、多すぎると遅くなると思います。すごく。
それに、スクロールしないと入力できないサイズだと使い勝手最悪です。


(2) 画面では比較のために、半分だけセルを選択して、ボタンを押そうとしているところです。


(3) 押した後。なかなかセンスのないボタンです。
真っ白でも動作するんですが、カウンターが「生きてるのか」どうかが判断しにくいので何かしら区別したほうがよさそう。
あと、塗りつぶしをありにして透明度を設定した方が見た目はすっきりですが、遅い感じ。


(4) ボタン的なものがあるセルを触るとこうなります。カーソルの「+」はIrfanViewのキャプチャ機能のショートカットにCTRLを使ってるので出ちゃってるだけで、実際には手のマーク。


(5) 何回か押してみた後。


(6) 全部数え終わったら印刷とかすると思います。その時に変に触って数字が変わるのが鬱陶しいはず。
なので、作成したボタンを消せるようにしてます。


マクロでやってるのは「ボタンをつくる」「ボタンを消す」だけ。
ボタンがやってるのは「1だけカウントアップ」だけ。
数字をクリアしたりどうこうするのは、エクセルでやりゃいい。やり直しもできるし。

#標準モジュール
'*******************************************
Const gShapeType = msoShapeRectangle
'*******************************************
'シェイプ削除
'*******************************************
Sub ClearShape()
Dim i As Long
i = 1
Do Until i > ActiveSheet.Shapes.Count
With ActiveSheet
If .Shapes(i).AutoShapeType = gShapeType Then
.Shapes(i).Delete
Else
i = i + 1
End If
End With
Loop
End Sub

'*******************************************
'シェイプ削除
'*******************************************
Sub CallClearShape()
Call ClearShape
End Sub

'*******************************************
'シェイプ作成
'*******************************************
Sub CreateShape(WithCellClear As Boolean)
Dim LoopArea As Range
Dim lShape As Shape

Set LoopArea = Selection
For i = 1 To LoopArea.Count
With LoopArea.Cells(i)
If WithCellClear Then .Value = ""
Set lShape = ActiveSheet.Shapes.AddShape(Type:=gShapeType, _
Left:=.Left + 1, Top:=.Top + 1, Width:=.Width - 2, Height:=.Height - 3)
lShape.Name = .Address(RowAbsolute:=False, ColumnAbsolute:=False)
lShape.Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(150, 150, 150)
.Style = msoLineDash
End With
lShape.OnAction = "CounterMacro"
Set lShape = Nothing
End With
Next

ActiveSheet.Range("A1").Select
End Sub

'*******************************************
'シェイプ作成
'*******************************************
Sub CallCreateShape()
Dim lRet As Integer
lRet = MsgBox("選択したセルをカウンターっぽくします。範囲はいい感じですか?", vbOKCancel, "確認")
If lRet = vbCancel Then
Exit Sub
End If
Call ClearShape
Call CreateShape(False)
End Sub

'----------------------------------------
'シェイプの置いてあるセルをカウントアップ
'----------------------------------------
Sub CounterMacro()
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
スポンサーサイト

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

ハイパーリンクをクリックして作成したマクロを起動するには
http://www.excel-wing.com/study/jitumu/941

Workbook.SheetFollowHyperlink イベント (Excel)
http://msdn.microsoft.com/ja-jp/library/office/ff838573(v=office.15).aspx

エクセルVBAでアクティブセルの位置を獲得するコードを教えてください
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1218931622

Excel2010でBook1のセルA1にハイパーリンクをVBAで付けたいと思います。
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1185661976

Hyperlinks.Add メソッド (Excel)
http://msdn.microsoft.com/ja-jp/library/office/ff822490(v=office.15).aspx

下線の設定
http://www.officepro.jp/excelvba/cell_font/index4.html

できたのがこれ。

#ThisWorkbook
'*************************************************************************
'http://www.excel-wing.com/study/jitumu/941
'http://msdn.microsoft.com/ja-jp/library/office/ff838573(v=office.15).aspx
'http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1218931622
'指定範囲のセルにハイパーリンクを設定(設定先は自分自身)
'内容を"0"にしてカウンター初期化
'*************************************************************************
Sub Test1()
Dim lRet As Integer
lRet = MsgBox("全部消します。やり直しできません。印刷しました?", vbOKCancel, "確認")
If lRet = vbCancel Then
Exit Sub
End If

Dim i As Long
Dim lRange As Range
Set lRange = Range("B2:AF6")
For i = 1 To lRange.Count
With lRange.Cells(i)
ActiveSheet.Hyperlinks.Add _
Anchor:=lRange.Cells(i), _
Address:="", _
SubAddress:=.Address(RowAbsolute:=False, ColumnAbsolute:=False), _
ScreenTip:=" ", _
TextToDisplay:="0"
.Value = "0"
End With
Next

lRange.Font.Size = 12
lRange.Font.Underline = False
lRange.Font.Color = vbBlack
End Sub

'*************************************************************************
'ハイパーリンクがクリックされたら数字を一つ上げる
'*************************************************************************
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
With ActiveCell
.Value = .Value + 1
End With
End Sub


めちゃ短くなった。ハイパーリンクを設定するとセルの書式が何かに初期化されるのがちょっと面倒。
あと、クリック間隔が短くなると、セルが編集モードになってしまいます。で、それを解除しようと別のセルをうかつに触ると予定外のセルがカウント上がる罠にはまります。

エクセルでセルをクリックしてカウンターもどきにする(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

これちょっといい感じかも。