VBA エクセル バレーボールの得点板 作りたい

質問

自分はVBA初心者のものです。VBAを使ってバレーボールの得点版のような、試合の流れがわかる
A　　B
１
２
　　　１
３

このような物を作りたいと考えております。自分は一つのセルに＋１する方法はわかるのですが、このような形のも野の作り方はわからないです。詳しい方いらっしゃいましたら是非教えていただきたいです

回答No.5

kon555 · ベストアンサー

バレーなどの得点と言うことは、例えば実際の試合などを観つつ記録していくような形でしょうか？
　とするとボタン操作などで加点していくのが簡単だと思います。

　まず得点表としては1行目を表題欄にします。A1セルに「A」B1セルに「B」、C1セルに「総得点」と入力し、A2、B2、C2を「0」と表記して下さい。
　これで表のベースは完成です。シンプルなので画像は割愛します。
　あとは下記の「A得点」「B得点」の2つのマクロを実行すると、お望みの形で得点表が作成されていきます。
　C2セルにはその時点の両チームの総得点が表示されています。邪魔なら非表示して下さい。

　適当な図形などにマクロ登録し、得点をクリックで記録する形が使い易いと思います。もしリアルタイムで観戦しながら得点表にを記録するならショートカットが便利かもしれないですが、その辺りはご自由に。

Sub A得点()
Dim i As Long, s As Long
i = 3 + Range("C2").Value
s = Cells(Rows.Count, 1).End(xlUp)
Cells(i, 1) = s + 1
Range("C2") = Range("C2") + 1
End Sub

Sub B得点()
Dim i As Long, s As Long
i = 3 + Range("C2").Value
s = Cells(Rows.Count, 2).End(xlUp)
Cells(i, 2) = s + 1
Range("C2") = Range("C2") + 1
End Sub

回答No.4

kkkkkm

No.2の補足です。

色々とっちらかってすみませんm(__)m

WorksheetFunction.Maxを使わずにやる場合です。こちらが普通な感じです。

Sub CountUp(ByVal mCol1 As String, mCol2 As String)
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim mRow As Long

LastRow1 = Cells(Rows.Count, mCol1).End(xlUp).Row
LastRow2 = Cells(Rows.Count, mCol2).End(xlUp).Row

If LastRow1 > LastRow2 Then
mRow = LastRow1
Else
mRow = LastRow2
End If
'最終行が1行目だと2行目にする
If LastRow1 = 1 Then
LastRow1 = 2
End If

Cells(mRow + 1, mCol1).Value = Cells(LastRow1, mCol1) + 1

End Sub

回答No.3

kkkkkm

No.1 No.2の補足です。

一行目が数値だとそこから加算されていきます。一行目に数値が入る可能性がある場合は

WorksheetFunction.Max(Range(Cells(2, mCol1), Cells(LastRow1 + 1, mCol1))) + 1

これにしておくと1行目が無視されますので、一行目が数値でも文字でも影響がなくなります。

回答No.2

kkkkkm

No1の補足です。

代入式を一行にしたい場合は(例は一か所にした方の場合)

Sub CountUp(ByVal mCol1 As String, mCol2 As String)
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim mRow As Long

LastRow1 = Cells(Rows.Count, mCol1).End(xlUp).Row
LastRow2 = Cells(Rows.Count, mCol2).End(xlUp).Row

If LastRow1 > LastRow2 Then
mRow = LastRow1
Else
mRow = LastRow2
End If
Cells(mRow + 1, mCol1).Value = WorksheetFunction.Max(Cells(2, mCol1), Cells(LastRow1, mCol1)) + 1
End Sub

回答No.1

kkkkkm

TestAはA列の加算用でTestBはB列加算用です。 2行目から開始します。

Sub TestA()
Dim LastRowA As Long
Dim LastRowB As Long

LastRowA = Cells(Rows.Count, "A").End(xlUp).Row
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row

If LastRowA > LastRowB Then
Cells(LastRowA + 1, "A").Value = WorksheetFunction.Max(Range(Cells(2, "A"), Cells(LastRowA, "A"))) + 1
Else
Cells(LastRowB + 1, "A").Value = WorksheetFunction.Max(Range(Cells(2, "A"), Cells(LastRowA, "A"))) + 1
End If
End Sub

Sub TestB()
Dim LastRowA As Long
Dim LastRowB As Long

LastRowA = Cells(Rows.Count, "A").End(xlUp).Row
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row

If LastRowA > LastRowB Then
Cells(LastRowA + 1, "B").Value = WorksheetFunction.Max(Range(Cells(2, "B"), Cells(LastRowB, "B"))) + 1
Else
Cells(LastRowB + 1, "B").Value = WorksheetFunction.Max(Range(Cells(2, "B"), Cells(LastRowB, "B"))) + 1
End If

End Sub

上記で同じようなコードを一か所にしたものが以下です。

Sub TestA2()
Call CountUp("A", "B")
End Sub

Sub TestB2()
Call CountUp("B", "A")
End Sub

Sub CountUp(ByVal mCol1 As String, mCol2 As String)
Dim LastRow1 As Long
Dim LastRow2 As Long

LastRow1 = Cells(Rows.Count, mCol1).End(xlUp).Row
LastRow2 = Cells(Rows.Count, mCol2).End(xlUp).Row

If LastRow1 > LastRow2 Then
Cells(LastRow1 + 1, mCol1).Value = WorksheetFunction.Max(Range(Cells(2, mCol1), Cells(LastRow1, mCol1))) + 1
Else
Cells(LastRow2 + 1, mCol1).Value = WorksheetFunction.Max(Range(Cells(2, mCol1), Cells(LastRow1, mCol1))) + 1
End If
End Sub

Max使うのは2行目に最初の値を入れるときに1行目が文字列だった場合単に
Cells(LastRow1, mCol1) + 1
とするとエラーになるのでそれを避けるためです。他にも方法があると思いますが今回はこれで。

また今回の場合は
WorksheetFunction.Max(Range(Cells(2, mCol1), Cells(LastRow1, mCol1))) + 1
は
WorksheetFunction.Max(Cells(2, mCol1), Cells(LastRow1, mCol1)) + 1
でもいけます。