VBAで●×ゲーム

---sheetに記載---
Public currentPlayer As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1:C3")) Is Nothing Then
If Target.Cells.count = 1 Then
If Target.Value = "" Then
If currentPlayer = "" Then currentPlayer = "○"

            ' 置く前に、自分の印が3つあるなら1つ削除
            Dim markCount As Integer
            markCount = CountMarks(currentPlayer)

            If markCount >= 3 Then
                RemoveOldestMark currentPlayer
            End If

            ' マーク設置
            Target.Value = currentPlayer
            With Target
                .Font.Size = 24
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
                If currentPlayer = "○" Then
                    .Font.Color = vbRed
                Else
                    .Font.Color = vbBlack
                End If
                .AddComment CStr(Now) ' コメントに時間を記録して順番判断に使う
            End With

            ' 勝敗判定
            If CheckWinner(currentPlayer) Then
                MsgBox currentPlayer & " の勝ち！"
                Exit Sub
            End If
            If IsBoardFull() Then
                MsgBox "引き分けです！"
                Exit Sub
            End If

            ' プレイヤー交代
            If currentPlayer = "○" Then
                currentPlayer = "×"
            Else
                currentPlayer = "○"
            End If
        End If
    End If
End If

End Sub

---モジュールに記載---
Public Function CheckWinner(player As String) As Boolean
Dim r As Integer, c As Integer
Dim rng As Range
' 横のチェック
For r = 1 To 3
Set rng = Range(Cells(r, 1), Cells(r, 3))
If WorksheetFunction.CountIf(rng, player) = 3 Then
CheckWinner = True
Exit Function
End If
Next r
' 縦のチェック
For c = 1 To 3
Set rng = Range(Cells(1, c), Cells(3, c))
If WorksheetFunction.CountIf(rng, player) = 3 Then
CheckWinner = True
Exit Function
End If
Next c
' 斜めチェック
If Cells(1, 1).Value = player And Cells(2, 2).Value = player And Cells(3, 3).Value = player Then
CheckWinner = True
Exit Function
End If
If Cells(1, 3).Value = player And Cells(2, 2).Value = player And Cells(3, 1).Value = player Then
CheckWinner = True
Exit Function
End If
CheckWinner = False
End Function

Public Function IsBoardFull() As Boolean
Dim cell As Range
For Each cell In Range("A1:C3")
If cell.Value = "" Then
IsBoardFull = False
Exit Function
End If
Next cell
IsBoardFull = True
End Function
'

' プレイヤーのマーク数を数える
Public Function CountMarks(player As String) As Integer
Dim cell As Range, count As Integer
For Each cell In Sheet1.Range("A1:C3")
If cell.Value = player Then count = count + 1
Next cell
CountMarks = count
End Function

' 一番古いマークを削除（コメントの時間順）
Public Sub RemoveOldestMark(player As String)
Dim cell As Range
Dim oldestCell As Range
Dim oldestTime As Date

oldestTime = Now
For Each cell In Sheet1.Range("A1:C3")
    If cell.Value = player Then
        If Not cell.Comment Is Nothing Then
            If cell.Comment.Text <> "" Then
                If CDate(cell.Comment.Text) < oldestTime Then
                    Set oldestCell = cell
                    oldestTime = CDate(cell.Comment.Text)
                End If
            End If
        End If
    End If
Next cell

If Not oldestCell Is Nothing Then
    oldestCell.ClearContents
    oldestCell.ClearComments
End If

End Sub

Public Sub ResetGame()
Dim cell As Range
For Each cell In Sheet1.Range("A1:C3")
With cell
.ClearContents
If Not .Comment Is Nothing Then .ClearComments
.Font.Color = vbBlack
.Font.Size = 24
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
End With
Next cell
currentPlayer = ""
End Sub