Automate straight numbers series verification-CodePudding

I am having troubles creating a small program to check if characters in a cell are straight under certain conditions. Let's say for instance that a cell contains the following characters "23465148", what I would like to know is whether 5 characters of this cell represent a straight chain of number (in this case yes, 12345).

The problem I have is the following one. I was only able to automate this verification on celles that contains 5 characters. But for cells that contain >5 characters, I am not sure how to proceed because I need to check every combinations of characeters in this cell.

Another problem I have is when the cell contain <5 or 5 or >5 characters. Whatever the number of characters, I would like to see how many of them are straight even if there are less than 5.

Below is the code I'm currently using. Note that in this case, the code is written for a card game (poker)

Do you have any suggestion I could include to complete my code?

Thank you

'This function will return TRUE if the 5 cards are a Straight
'sHand is a string corresponding to the 5 cards in hand, for example : 237TK
Function IsAStraight(sHand As String) As Boolean
    Dim arCards(1 To 5, 1 To 2)
    Dim i As Integer, sSortedHand As String
    
    Const sStraight As String = "KQJT98765432A|KQJTA"
    Const sCardsRanked As String = "A23456789TJQK"
    
    'Get the cards values
    For i = 1 To 5
        arCards(i, 1) = Mid(sHand, i, 1)
        arCards(i, 2) = InStr(1, sCardsRanked, Mid(sHand, i, 1))
    Next i
    
    'Sort by value descending
    Sort2DVert arCards, 2, "D"
    
    'Sorted hand
    For i = 1 To 5
        sSortedHand = sSortedHand & arCards(i, 1)
    Next i
    
    'Check if this is a straight
    IsAStraight = InStr(1, sStraight, sSortedHand) > 0

End Function

'Sort a 2D Array
Public Sub Sort2DVert(avArray As Variant, iKey As Integer, sOrder As String, Optional iLow1, Optional iHigh1)
    Dim iLow2 As Long, iHigh2 As Long, i As Long
    Dim vItem1, vItem2 As Variant
    
    On Error GoTo PtrExit
    If IsMissing(iLow1) Then iLow1 = LBound(avArray)
    If IsMissing(iHigh1) Then iHigh1 = UBound(avArray)
    iLow2 = iLow1: iHigh2 = iHigh1
    vItem1 = avArray((iLow1   iHigh1) \ 2, iKey)
    
    'Loop for all the items in the array between the extremes
    Do While iLow2 < iHigh2
        If sOrder = "A" Then
            Do While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1: iLow2 = iLow2   1: Loop
            Do While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1: iHigh2 = iHigh2 - 1: Loop
        Else
            Do While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1: iLow2 = iLow2   1: Loop
            Do While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1: iHigh2 = iHigh2 - 1: Loop
        End If
        
        If iLow2 < iHigh2 Then
            For i = LBound(avArray, 2) To UBound(avArray, 2)
                vItem2 = avArray(iLow2, i)
                avArray(iLow2, i) = avArray(iHigh2, i)
                avArray(iHigh2, i) = vItem2
            Next
        End If
        If iLow2 <= iHigh2 Then
            iLow2 = iLow2   1
            iHigh2 = iHigh2 - 1
        End If
    Loop
    
    If iHigh2 > iLow1 Then Sort2DVert avArray, iKey, sOrder, iLow1, iHigh2
    If iLow2 < iHigh1 Then Sort2DVert avArray, iKey, sOrder, iLow2, iHigh1
    
PtrExit:
End Sub

CodePudding user response：

You could do something like this:

Sub tester()
    Dim arr, runs As Collection, run, hand
    arr = Array("7A596A8KQ", "787878", "A87", "A2QJ4K3", "468JK")
    For Each hand In arr
        Debug.Print "---------" & hand & "---------"
        Set runs = Straights(CStr(hand))
        For Each run In runs
            Debug.Print " - " & run
        Next run
    Next hand
End Sub

'return a collection of all runs in `sHand`
Function Straights(sHand As String) As Collection 'of strings
    Const ranked As String = "A23456789TJQK"
    Dim i As Long, run As Boolean, rlen As Long
    Dim rStart As Long, arr() As Long, p As Long
    Dim hadRun As Boolean, runs As New Collection, last As Boolean
    
    ReDim arr(1 To Len(ranked))
    'first count all cards in the hand
    For i = 1 To Len(sHand)
        p = InStr(1, ranked, Mid(sHand, i, 1))
        arr(p) = arr(p)   1
    Next i
    'now check for runs: keep looping over `arr` until no more runs are found
    Do
        hadRun = False                            'reset flag
        For i = 2 To UBound(arr)
            last = (i = UBound(arr))             'last element?
            run = arr(i) > 0 And arr(i - 1) > 0  'in a run?
            
            If run Then
                hadRun = True                      'flag found a run in this go round
                If rlen = 0 Then
                    rStart = i - 1                 'new run: record start position
                    arr(i - 1) = arr(i - 1) - 1    'decrement count at i-1
                    rlen = 2                       'set initial length
                Else
                    arr(i) = arr(i) - 1            'decrement count at i
                    rlen = rlen   1
                End If
            End If
            If Not run Or (run And last) Then   'at end, or end of a run?
                If rlen > 0 Then                           'previously in a run?
                    runs.Add Mid(ranked, rStart, rlen)     'add run to output
                    rlen = 0                               'reset run length
                End If
            End If
        Next i
        rlen = 0
        If Not hadRun Then Exit Do 'no more runs found
    Loop  'keep checking as long as there was a run in this iteration
    Set Straights = runs
End Function