Lottery Bingo Conundrum

[LambChops]

At work we run a lottery bingo where 30 people pick 6 numbers each from a total of 30 numbers, the easy bit is highlighting a persons number when one is drawn using conditional formatting but I need to highlight a person if they have absolutely no chance of winning the game due to other people waiting on a number they require, for example;


Person1 is waiting for numbers 1 & 2 to come up
Person2 is waiting for number 1 to come up
Person3 is waiting for number 2 to come up




It is impossible for person1 to win as no matter which number is drawn (1 or 2) someone else will win and in this case they stop paying into the current game and start paying into the next game.


It can also be impossible for person1 to win if others are waiting for more than 1 number: -


Person1 is waiting for numbers 1,2,3 & 4 to come up
Person2 is waiting for number 1 & 2 to come up
Person3 is waiting for number 3 & 4 to come up


So how can this be solved programatically or via formulas?


Thanks

 

[StephenCrump]

I think the code below works. I've switched to using names rather than numbers, so the code expects to find a range name called PlayerNames (e.g. D3:D28 using the layout from post #3 above):

Sub TestBingoWinners()

    Dim vNumbersDrawn As Variant, vNumbersSelected As Variant
    Dim vNames As Variant
    Dim lNoPlayers As Long, lRoundNo As Long
    Dim i As Long, j As Long, n As Long, p As Long
    Dim bNumbersOutstanding() As Boolean, bNumbersToCheck() As Boolean
    Dim lCountOutstanding() As Long, lNumbersToTickOff As Long
    Dim lPlayersToTest() As Long, lNoPlayersToTest As Long
    Dim bTestThisPlayer As Boolean, bGameWon As Boolean, bPlayerLoses As Boolean
    Dim sMsgText As String
    Const NOS = 30
    Const NO_SELECTED = 6
    
    vNumbersDrawn = [NumbersDrawn].Value
    vNumbersSelected = [NumbersSelected].Value
    vNames = [PlayerNames].Value
    lNoPlayers = UBound(vNumbersSelected, 1)
    lRoundNo = [RoundNo]
    ReDim bNumbersOutstanding(1 To lNoPlayers, 1 To NOS)
    ReDim bNumbersToCheck(1 To NOS)
    ReDim lCountOutstanding(1 To lNoPlayers)
    ReDim lPlayersToTest(1 To lNoPlayers)
    
    For i = 1 To lNoPlayers
        'Initial position
        lCountOutstanding(i) = NO_SELECTED
        For n = 1 To NO_SELECTED
            bNumbersOutstanding(i, vNumbersSelected(i, n)) = True
        Next n
        'Position after the given numbers have been drawn
        For n = 1 To lRoundNo
            If bNumbersOutstanding(i, vNumbersDrawn(n, 1)) Then
                bNumbersOutstanding(i, vNumbersDrawn(n, 1)) = False
                lCountOutstanding(i) = lCountOutstanding(i) - 1
                If lCountOutstanding(i) = 0 Then
                    MsgBox "Round " & n & ": Player " & i & " is a winner!"
                    bGameWon = True
                    Exit For
                End If
            End If
        Next n
    Next i
    If bGameWon Then GoTo EndSub
    
    For i = 1 To lNoPlayers
        'Test for other players that may always win
        lNoPlayersToTest = 0
        For p = 1 To lNoPlayers
            bTestThisPlayer = False
            If p <> i And lCountOutstanding(p) < lCountOutstanding(i) Then
                bTestThisPlayer = True
                For n = 1 To NOS
                    If bNumbersOutstanding(p, n) And Not bNumbersOutstanding(i, n) Then
                        bTestThisPlayer = False
                        Exit For
                    End If
                Next n
                If bTestThisPlayer Then
                    lNoPlayersToTest = lNoPlayersToTest + 1
                    lPlayersToTest(lNoPlayersToTest) = p
                End If
            End If
        Next p
        If lNoPlayersToTest > 1 Then
            'Need to check that each of Player i's numbers is not held by at least one player in this select group
            lNumbersToTickOff = lCountOutstanding(i)
            For n = 1 To NOS
                If bNumbersOutstanding(i, n) Then
                    bNumbersToCheck(n) = True
                Else
                    bNumbersToCheck(n) = False
                End If
            Next n
            For n = 1 To NOS
                If bNumbersToCheck(n) Then
                    For j = 1 To lNoPlayersToTest
                        If Not bNumbersOutstanding(lPlayersToTest(j), n) Then
                            bNumbersToCheck(n) = False
                            lNumbersToTickOff = lNumbersToTickOff - 1
                            Exit For
                        End If
                    Next j
                End If
            Next n
            If lNumbersToTickOff = 0 Then
                sMsgText = vNames(lPlayersToTest(1), 1)
                For j = 2 To lNoPlayersToTest - 1
                    sMsgText = sMsgText & ", " & vNames(lPlayersToTest(j), 1)
                Next j
                sMsgText = sMsgText & " and " & vNames(lPlayersToTest(lNoPlayersToTest), 1)
                MsgBox "Round " & lRoundNo & ": " & vNames(i, 1) & " can't win because of players " & sMsgText
                bPlayerLoses = True
            End If
        End If
    Next i
    If Not bPlayerLoses Then MsgBox "No results yet ..."

EndSub:

End Sub