キーカウンター（数取器） - 病理診断を Excel を使ってやってみる

キーカウンター（数取器）

数取器（カウンター）をエクセル上で作ってみます。10連式キーカウンターです。

https://gyazo.com/0e2bfb6142a69c0b5518d85f65ee1f3a

/nananana-icon/入力.icon 入力：asdzxcvbnmキーによる直接入力(連打)

/nananana-icon/処理.icon 処理：キーカウントと百分率表示

/nananana-icon/出力.icon 出力：画面上に表示のみ

簡単なマクロで作るのなら、Ctrl＋各キー入力で各セルに1足すようにすれば実現できます。親指でコントロールキーを押しながら、zキーを連打する感じです。

さらに、

ブックが開いたときに自動でマクロを実行したい　Workbook_Open

キーを押してマクロを実行する　Application.OnKey

ようにすれば、Ctrlキーを押さずに各キー入力のみでカウントできるようになります。直接入力は英数字キーに限定されますが、マクロを拡張すれば、30連式カウンターくらいまでは実現可能です。

他に追加できる機能としては、入力データの出力機能として、

出力を並べてまとめる

複数行にわたるセルを改行されたデータとしてコピーする

デジタル白血球分画カウンターでは、100個数えたところでブザーが鳴る機能があるので、

PCの音を鳴らしてやる

のもいいかもしれません。

マクロを拡張して、

必要の無いキーを押しても入力されないようにする

入力場所を固定することで応用すると、NAPスコアの自動計算なども可能です。

→　Excel VBAを利用したNAPスコア算定システムの開発

#参考論文

nananana.icon　カウンターアプリケーション作成そのものの論文もありました。完成度の高いエクセルテンプレートが学会のサイトよりダウンロードできます。

DOI https://doi.org/10.6010/geoinformatics.26.1_15

論文.icon　志村俊昭・小島萌（2015）エクセルVBAによるポイントカウント・アプリケーション. 情報地質, 26, 15-20.

日本情報地質学会のホームページ　http://www.jsgi.org/　からダウンロードできます．

Exce-VBA Counter

志村俊昭・小島萌 (2014.12.12)'　（Windows推奨版・右手用）

#If VBA7 And Win64 Then '64ビット版Office

Declare PtrSafe Function ApiBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As LongPtr, ByVal dwDuration As LongPtr) As Long

#Else '32ビット版Office

Declare Function ApiBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

#End If

' dwFreq = 周波数（単位 Hz）

' dwDuration = 鳴動時間(単位ミリ秒)

' Windowsのみ有意。Macの場合ここまでの全行を消すかREM文にする。

Sub スタートボタン()

Call KeyboardOn

Range("A1").Activate '念のため，「停止中」に意図せずキーに触れたら、打った文字がセルA1に入る仕掛け。

Cells(10, 7).Interior.ColorIndex = 4

Cells(10, 7).Font.ColorIndex = 3

Range("G10") = "カウント中"

Call KeyboardOff

Call キー判定分岐

End Sub

Sub KeyboardOff()

Application.OnKey "^d", "KeyboardOn" '念のための緊急脱出用隠しキー。CTRL+D でキーボードONに戻せる仕掛け。

Application.DataEntryMode = True

End Sub

Sub KeyboardOn()

Application.DataEntryMode = False

End Sub

Sub キー判定分岐()

Application.OnKey "7", "keyや"

Application.OnKey "8", "keyゆ"

Application.OnKey "9", "keyよ"

Application.OnKey "0", "keyわ"

Application.OnKey "u", "keyU"

Application.OnKey "i", "keyI"

Application.OnKey "o", "keyO"

Application.OnKey "p", "keyP"

Application.OnKey "j", "keyJ"

Application.OnKey "k", "keyK"

Application.OnKey "l", "keyL"

Application.OnKey ";", "keyれ"

Application.OnKey "m", "keyM"

Application.OnKey ",", "keyね"

Application.OnKey ".", "keyる"

End Sub

Sub ストップボタン()

Call キー停止

Call 集計

End Sub

Sub リセットボタン()

Beep

Dim rc As Integer

rc = MsgBox("カウント値をリセットしますか？", vbYesNo + vbQuestion, "確認")

If rc = vbYes Then

Range("B6") = 0

Range("C6") = 0

Range("D6") = 0

Range("E6") = 0

Range("B11") = 0

Range("C11") = 0

Range("D11") = 0

Range("E11") = 0

Range("B16") = 0

Range("C16") = 0

Range("D16") = 0

Range("E16") = 0

Range("B21") = 0

Range("C21") = 0

Range("D21") = 0

Cells(6, 8).Interior.ColorIndex = 4

Cells(6, 8).Font.ColorIndex = 1

Else

End If

Call キー停止

Call 集計

End Sub

Sub keyや()

Range("B6") = Range("B6") + 1

Call 判定

End Sub

Sub keyゆ()

Range("C6") = Range("C6") + 1

Call 判定

End Sub

Sub keyよ()

Range("D6") = Range("D6") + 1

Call 判定

End Sub

Sub keyわ()

Range("E6") = Range("E6") + 1

Call 判定

End Sub

Sub keyU()

Range("B11") = Range("B11") + 1

Call 判定

End Sub

Sub keyI()

Range("C11") = Range("C11") + 1

Call 判定

End Sub

Sub keyO()

Range("D11") = Range("D11") + 1

Call 判定

End Sub

Sub keyP()

Range("E11") = Range("E11") + 1

Call 判定

End Sub

Sub keyJ()

Range("B16") = Range("B16") + 1

Call 判定

End Sub

Sub keyK()

Range("C16") = Range("C16") + 1

Call 判定

End Sub

Sub keyL()

Range("D16") = Range("D16") + 1

Call 判定

End Sub

Sub keyれ()

Range("E16") = Range("E16") + 1

Call 判定

End Sub

Sub keyM()

Range("B21") = Range("B21") + 1

Call 判定

End Sub

Sub keyね()

Range("C21") = Range("C21") + 1

Call 判定

End Sub

Sub keyる()

Range("D21") = Range("D21") + 1

Call 判定

End Sub

Sub 判定()

If Range("H6").Value < Range("H7").Value Then

Call ApiBeep(1000, 50) ' Beep音の周波数と時間。Windowsのみ有意。Macの場合この行を消すかREM文にする。

Cells(6, 8).Interior.ColorIndex = 4

Cells(6, 8).Font.ColorIndex = 1

Else

Call ApiBeep(2000, 50) ' Beep音の周波数と時間。Windowsのみ有意。Macの場合この行を消すかREM文にする。

Cells(6, 8).Interior.ColorIndex = 6

Cells(6, 8).Font.ColorIndex = 3

End If

End Sub

Sub キー停止()

Call KeyboardOn

Range("A1").Activate

Cells(10, 7).Interior.ColorIndex = 15

Cells(10, 7).Font.ColorIndex = 1

Range("G10") = "停止中"

Application.OnKey "7"

Application.OnKey "8"

Application.OnKey "9"

Application.OnKey "0"

Application.OnKey "u"

Application.OnKey "i"

Application.OnKey "o"

Application.OnKey "p"

Application.OnKey "j"

Application.OnKey "k"

Application.OnKey "l"

Application.OnKey ";"

Application.OnKey "m"

Application.OnKey ","

Application.OnKey "."

End Sub

Sub 集計()

Range("B33") = Range("B5")

Range("B34") = Range("C5")

Range("B35") = Range("D5")

Range("B36") = Range("E5")

Range("B37") = Range("B10")

Range("B38") = Range("C10")

Range("B39") = Range("D10")

Range("B40") = Range("E10")

Range("B41") = Range("B15")

Range("B42") = Range("C15")

Range("B43") = Range("D15")

Range("B44") = Range("E15")

Range("B45") = Range("B20")

Range("B46") = Range("C20")

Range("B47") = Range("D20")

Range("C33") = Range("B6")

Range("C34") = Range("C6")

Range("C35") = Range("D6")

Range("C36") = Range("E6")

Range("C37") = Range("B11")

Range("C38") = Range("C11")

Range("C39") = Range("D11")

Range("C40") = Range("E11")

Range("C41") = Range("B16")

Range("C42") = Range("C16")

Range("C43") = Range("D16")

Range("C44") = Range("E16")

Range("C45") = Range("B21")

Range("C46") = Range("C21")

Range("C47") = Range("D21")

Range("D33") = Range("B7")

Range("D34") = Range("C7")

Range("D35") = Range("D7")

Range("D36") = Range("E7")

Range("D37") = Range("B12")

Range("D38") = Range("C12")

Range("D39") = Range("D12")

Range("D40") = Range("E12")

Range("D41") = Range("B17")

Range("D42") = Range("C17")

Range("D43") = Range("D17")

Range("D44") = Range("E17")

Range("D45") = Range("B22")

Range("D46") = Range("C22")

Range("D47") = Range("D22")

Range("C48") = WorksheetFunction.Sum(Range("C33", "C47"))

If Range("C48").Value = 0 Then

Range("D48").Value = 0

Else

Range("D48") = WorksheetFunction.Sum(Range("D33", "D47"))

End If

End Sub

https://gyazo.com/7892c236eab082387b4c0a0dc3af01ab

サイトメニュー