Consulting

Results 1 to 6 of 6

Thread: Blockbusters Array

  1. #1
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,017
    Location

    Blockbusters Array

    Hi

    I have made up a sheet containing a grid of 4x5 hexagons to re-create the 1980's gameshow "Blockbusters".

    For those of you young enough(and lucky enough!) not to remember it, it was a quiz for two teams (1 person v 2 people) answering questions to cross a grid.

    I would like to detect when a team has won, ie crossed the grid.

    I have put the grid into two arrays, one for crossing left to right, and one for top to bottom.

    I started writing code using IF statements:

    Sub MyAlgArray()
        Dim A() As Variant
        A = Sheet1.Range("i12:m15")
        'Line across top
        If A(1, 1) = 1 And A(1, 2) = 1 Or A(1, 1) = 1 And A(2, 2) = 1 Then
            If A(1, 3) = 1 And A(2, 4) = 1 And A(2, 5) Then MsgBox "Equal"
            If A(1, 3) = 1 And A(1, 4) = 1 Or A(1, 3) = 1 And A(2, 4) = 1 Then
                If A(1, 5) = 1 Then MsgBox "Equal"
            End If
        End If
        
        '2nd line
        If A(2, 1) = 1 And A(2, 2) = 1 Or A(2, 1) = 1 And A(3, 2) = 1 Then
            If A(2, 3) = 1 And A(2, 4) = 1 And A(1, 5) Then MsgBox "Equal"
            If A(2, 3) = 1 And A(3, 4) = 1 And A(3, 5) Then MsgBox "Equal"
            If A(2, 3) = 1 And A(2, 4) = 1 Or A(2, 3) = 1 And A(3, 4) = 1 Then
                If A(2, 5) = 1 Then MsgBox "Equal"
            End If
        End If
        '3rd line
        If A(3, 1) = 1 And A(3, 2) = 1 Or A(3, 1) = 1 And A(4, 2) = 1 Then
            If A(3, 3) = 1 And A(3, 4) = 1 Or A(3, 3) = 1 And A(4, 4) = 1 Then
                If A(3, 5) = 1 Then MsgBox "Equal"
            End If
        End If
        '4th line
        If A(4, 1) = 1 And A(4, 2) = 1 Then
            If A(4, 2) = 1 And A(3, 3) = 1 Or A(4, 2) = 1 And A(4, 3) = 1 Then
                If A(4, 4) = 1 And A(3, 5) = 1 Or A(4, 4) = 1 And A(4, 5) = 1 Then MsgBox "Equal"
            End If
        End If
    End Sub
    As you can see, this has got very messy very quickly, and this is just for the basic right to left crossing.

    Any ideas how this can be done more efficiently?

    Best regards

    Paul Ked
    Semper in excretia sumus; solum profundum variat.

  2. #2
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    7,398
    Location
    I think I understood the game

    If the worksheet grid was always 1's or 0's, it'd be simpler

     
    Option Explicit
    Dim A() As Variant
    
    Sub CheckOnes()
        Dim iRow As Long, iCol As Long
        
        A = Sheet1.Range("i12:m15").Value
        
        'make array only 1's and 0's
        For iRow = LBound(A, 1) To UBound(A, 1)
            For iCol = LBound(A, 2) To UBound(A, 2)
                If Len(A(iRow, iCol)) = 0 Then
                    A(iRow, iCol) = 0
                Else
                    A(iRow, iCol) = 1
                End If
            Next iCol
        Next iRow
        
        'check rows
        For iRow = LBound(A, 1) To UBound(A, 1)
            If pvtSumArray(iRow, 0) = UBound(A, 2) Then
                MsgBox "Row " & iRow & " = " & UBound(A, 2)
            End If
        Next iRow
        
        'check cols
        For iCol = LBound(A, 2) To UBound(A, 2)
            If pvtSumArray(0, iCol) = UBound(A, 1) Then
                MsgBox "Column " & iCol & " = " & UBound(A, 1)
            End If
        Next iCol
    End Sub
    
    Private Function pvtSumArray(Optional iRowSum As Long = 0, Optional iColSum As Long = 0) As Long
        Dim i As Long, iHold As Long
        
        'sum accross row = iRowSum
        If iRowSum > 0 Then
            For i = LBound(A, 2) To UBound(A, 2)
                iHold = iHold + A(iRowSum, i)
            Next I
            
        'sum down col = iColSum
        ElseIf iColSum > 0 Then
            For i = LBound(A, 1) To UBound(A, 1)
                iHold = iHold + A(i, iColSum)
            Next I
        End If
            
        pvtSumArray = iHold
    End Function
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,017
    Location
    Hi Paul.

    Thanks for reply, but unfortunately it doesn't solve the problem.

    As the 'boxes' are hexagonal there are numerous connections to get from one side of the grid to the other (see modification to your book attached).

    This is where the headache begins!

    Best Regards

    Paul Ked

    PS. I have set up two arrays which are only ones and zeros, one array for team A (L to R) and the other for team B (T to B).
    Attached Files Attached Files
    Semper in excretia sumus; solum profundum variat.

  4. #4
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,017
    Location
    Whilst digging around, I found this:

    For each player, loop through all the cells; if the cell is owned by the player, and is adjacent on one if it's six sides to a cell 'marked' by this fill routine, then the cell gets marked too. Loop again through all the cells, and again until no cells get marked to the current player. Here's some pseudo-code:
    for player in players:
    # those on the starting edge that the player owns get 'marked'
    for cells in cells.start_edge(player):
    if cell.owner = player:
    cell.mark = player
    do:
    count = 0
    for cell in cells:
    if cell.mark == None && cell.owner == player:
    for adjacent in cell.neighbours:
    if adjacent.mark == player
    cell.owner = player
    count += 1
    break
    while count
    for cell in cells.stop_edge(player):
    if cell.mark == player
    player won!!
    Semper in excretia sumus; solum profundum variat.

  5. #5
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,017
    Location
    ?????

    Don't know what happened, but last part went AWOL!

    I understand the logic but don't know how to code it. Any help would be much appreciated.

    Best regards

    Paul Ked
    Semper in excretia sumus; solum profundum variat.

  6. #6
    solved problem?

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •