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