スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

エクセルでセルをクリックしてカウンターもどきにする(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
関連記事
スポンサーサイト
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。