Automate straight numbers series verification - vba

Question

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

Answer 1

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