Double Elimination Sports Tournament Bracket

Try this version - also in the attached.

Attachment 317316

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True

    Dim row As Integer
    Dim col As Integer
    Dim strLoser As String
    Dim rngLoser As Range
    Dim rngGame As Range
    Dim rngNextGame As Range
    Dim rngTitle As Range
    
    row = Target.row
    col = Target.Column + IIf(Target.Column < 7, 1, -1)
    
    If Cells(1, Target.Column).Value > Target.row Then
        Set rngGame = Target.Resize(Cells(1, Target.Column).Value)
        strLoser = rngGame.Cells(rngGame.Cells.Count).Value
        GoTo GotGame
    End If
    If Application.CountA(Target.Resize(Cells(1, Target.Column).Value)) < Application.CountA(Target.Offset(1 - Cells(1, Target.Column).Value).Resize(Cells(1, Target.Column).Value)) Then
        Set rngGame = Target.Offset(1 - Cells(1, Target.Column).Value).Resize(Cells(1, Target.Column).Value)
        strLoser = rngGame.Cells(1).Value
    Else
        Set rngGame = Target.Resize(Cells(1, Target.Column).Value)
        strLoser = rngGame.Cells(rngGame.Cells.Count).Value
    End If
    
GotGame:

    If strLoser = "" Then
        MsgBox "That team had no opponent"
        Exit Sub
    End If

    Set rngNextGame = NGame(rngGame, col)
    
    If rngNextGame Is Nothing Then
        MsgBox "Oh-oh - check your color fill for the next game"
        Exit Sub
    End If
    
    Application.EnableEvents = False
    
    If col < Target.Column Then
         rngNextGame.Value = Target.Value
         GoTo ResetEvents
    End If

    If rngNextGame.Value <> "" Then
        If MsgBox("This game has already been entered. Change the winner?", vbYesNo) = vbNo Then GoTo ResetEvents
        rngNextGame.Value = Target.Value
        Set rngLoser = Range("G:P").Find(Target.Value, Range("G1"), xlValues, xlWhole)
        rngLoser.Value = strLoser
    Else
        rngNextGame.Value = Target.Value
        Set rngTitle = rngGame.Resize(rngGame.Cells.Count - 2).Offset(1).Find("* G*")
        Set rngLoser = Range("G:P").Find(Application.Trim("Loser " & Mid(rngTitle.Value, InStrRev(rngTitle.Value, " G"))), Range("G1"), xlValues, xlWhole)
        If rngLoser Is Nothing Then
              MsgBox Application.Trim("Loser " & Mid(rngTitle.Value, InStrRev(rngTitle.Value, " G"))) & "  is missing"
        End If
        rngLoser.Value = strLoser
    End If
ResetEvents:
    Application.EnableEvents = True
     
End Sub

Function NGame(r1 As Range, c1 As Integer) As Range
    Dim r As Range
    For Each r In r1
        If Cells(r.row, c1).Interior.ColorIndex = r1.Cells(1).Interior.ColorIndex Then
            Set NGame = Cells(r.row, c1)
            Exit Function
        End If
    Next r
End Function