Finding Largest repeated letter between two columns a/o rows

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