Finding Largest repeated letter between two columns a/o rows - excel

Question

I try to find largest consecutive letter between two dynamic colums.
Below code find largest consequent letter below same column (like C10:C50) however I want to check different range like "D13:D23;E9:E12". Below code brings me fault. Also can anyone help me to how I can convert it to row defined.
Function CountConsVal(r As Range)
Dim i As Long, s As Long
Rng = r.Value
For i = LBound(Rng, 1) To UBound(Rng, 1) - 1
If Rng(i, 1) = Rng(i + 1, 1) Then
s = s + 1
Rng(i, 1) = ""
Else
Rng(i, 1) = s + 1
s = 0
End If
Next i
Rng(UBound(Rng), 1) = s + 1
CountConsVal = Rng
End Function

Answer 1

Counting Consecutive Group Members
This is the same function you provided a little more readable with some minor changes.
Range("B1:B6").Value = GetGroupCountCols(Range("A1:A6"))
A B
1 a
2 a
3 a 3
4 b
5 b 2
6 c 1
Function GetGroupCountCols(ByVal rg As Range) As Variant
If rg Is Nothing Then Exit Function
Dim drCount As Long: drCount = rg.Rows.Count
Dim cData As Variant
If drCount = 1 Then ' one cell
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = 1
Else ' multiple cells
cData = rg.Columns(1).Value ' ensure one column
Dim r As Long, rCount As Long
For r = 1 To drCount - 1
If cData(r, 1) = cData(r + 1, 1) Then
cData(r, 1) = Empty: rCount = rCount + 1
Else
cData(r, 1) = rCount + 1: rCount = 0
End If
Next r
cData(drCount, 1) = rCount + 1
End If
GetGroupCountCols = cData
End Function
This is the same function but for rows.
Range("A2:F2").Value = GetGroupCountRows(Range("A1:F1"))
A B C D E F
1 a a a b b c
2 3 2 1
Function GetGroupCountRows(ByVal rg As Range) As Variant
If rg Is Nothing Then Exit Function
Dim dcCount As Long: dcCount = rg.Columns.Count
Dim rData As Variant
If dcCount = 1 Then ' one cell
ReDim rData(1 To 1, 1 To 1): rData(1, 1) = 1
Else ' multiple cells
rData = rg.Rows(1).Value ' ensure one row
Dim c As Long, cCount As Long
For c = 1 To dcCount - 1
If rData(1, c) = rData(1, c + 1) Then
rData(1, c) = Empty: cCount = cCount + 1
Else
rData(1, c) = cCount + 1: cCount = 0
End If
Next c
rData(1, dcCount) = cCount + 1
End If
GetGroupCountRows = rData
End Function
This is a test for the following two functions:
Sub GetGroupColumnsCountTEST()
Dim rg As Range: Set rg = Range("I10:I12,F4:F6,G7:G9")
Debug.Print rg.Address
Dim Data As Variant: Data = GetGroupColumnsCount(GetMultiColumns(rg))
Dim rg2 As Range: Set rg2 = Range("K4").Resize(UBound(Data, 1))
rg2.Value = Data
End Sub
This function will return the values of multiple column ranges in a 2D one-based one-column array.
Range("F1:F6").Value = GetMultiColumns(Range("E6,A1:A3,C4:C5")) ' see previous procedure
A B C D E F
1 a a
2 a a
3 b b
4 c c
5 c c
6 d d
Function GetMultiColumns(ByVal mrg As Range) As Variant
If mrg Is Nothing Then Exit Function
' Write data to a jagged array.
Dim aCount As Long: aCount = mrg.Areas.Count
Dim aData As Variant: ReDim aData(1 To aCount, 1 To 3)
Dim Help As Variant: ReDim Help(1 To 1, 1 To 1)
Dim a As Long
Dim arCount As Long, drCount As Long
For a = 1 To aCount
With mrg.Areas(a)
aData(a, 1) = .Row
aData(a, 2) = .Rows.Count
drCount = drCount + aData(a, 2)
If aData(a, 2) = 1 Then
aData(a, 3) = Help: aData(a, 3)(1, 1) = .Value
Else
aData(a, 3) = .Value
End If
End With
Next a
' Bubble sort the array by its first column (first rows) ascending.
ReDim Help(1 To 1)
Dim b As Long, c As Long
For a = 1 To aCount - 1
For b = a To aCount
If aData(a, 1) > aData(b, 1) Then
For c = 1 To 3
Help(1) = aData(a, c)
aData(a, c) = aData(b, c)
aData(b, c) = Help(1)
Next c
End If
Next b
Next a
' Write result.
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
Dim dr As Long
For a = 1 To aCount
Dim r As Long, rCount As Long
For r = 1 To aData(a, 2)
dr = dr + 1
dData(dr, 1) = aData(a, 3)(r, 1)
Next r
Next a
GetMultiColumns = dData
End Function
This is the same as your function but it takes a 2D one-based one-column array instead of a one-column range as the argument.
Function GetGroupColumnsCount(ByVal sData As Variant) As Variant
If IsEmpty(sData) Then Exit Function
Dim drCount As Long: drCount = UBound(sData, 1)
Dim cData As Variant: ReDim cData(1 To drCount, 1 To 1)
If drCount = 1 Then
cData(1, 1) = sData(1, 1)
Else
Dim r As Long, rCount As Long
For r = 1 To drCount - 1
If sData(r, 1) = sData(r + 1, 1) Then
rCount = rCount + 1
Else
cData(r, 1) = rCount + 1: rCount = 0
End If
Next r
cData(drCount, 1) = rCount + 1
End If
GetGroupColumnsCount = cData
End Function
To conclude, the last two functions do what you primarily requested. The only job for you is to combine them into one if necessary.

Answer 2

It seems you want to determine the maximum consecutive "r" values in each of many rows, one row at a time.
I suggest a User Defined Function with a one-row argument
Optionally check that the range argument is valid
read the range into a variant array for faster processing
Use a dictionary to collect each consecutive group of r's
Iterate through the dictionary to find the longest
Divide the final count by two to convert to hours
I used early-binding for the Dictionary object, but you can use late-binding if you prefer. Early-binding may execute slightly faster.
'Set reference to Microsoft Scripting Runtime
Option Explicit
Option Compare Text 'case insensitive
Function LongestConsecutiveRestingHrs(rw As Range) As Double
Dim vRw As Variant, v As Variant
Dim dict As Dictionary
Dim lCount As Long
Dim I As Long
'Optional sanity check: eg:
'confirm rw is 48 columns x 1 row
'If Not rw.Rows.Count = 1 Or Not rw.Columns.Count = 48 Then
' MsgBox "Invalid Range: " & rw.Address & vbLf & "Please enter valid range"
' Exit Function
'read into variant array for faster processing
vRw = rw
'count consecutive "r" groups
Set dict = New Dictionary
I = 0
For Each v In vRw 'can do this since vRw will be a 1D array
If v <> "r" Then
I = I + 1
Else
dict(I) = dict(I) + 1
End If
Next v
'find max r
I = 0
For Each v In dict.Keys
I = IIf(I > dict(v), I, dict(v))
Next v
LongestConsecutiveRestingHrs = I / 2
End Function