VBA: Subrange based on colorindex does not work correctly, Couting appearances also not

I updated the code as it now correctly uses the ranges but freezes all the time. Any ideas how to make it more efficient?

I created a code that defines mainranges based on the colorindex 55 and that works pretty finde. Within these ranges I have to create subranges based on the colorindex 37. There can be various subranges within one mainrange and therefore the name should be for subranges "main_range_name" & "C1" for first subrange, C2 for second, C3 for the third etc. Unfortunately, the code gives me only one subrange for each mainrange just with a C at the end. In addition, the subranges are not correctly assigned to the mainrange e.g. subrange "ABCD_C" gives me a subrange of the mainrange "WXYZ".

here is the code:

Sub Testbook1()

    Dim currentRangeStart As Long
    currentRangeStart = 1 'assuming data starts at row 2

    Dim currentClientName As String
    currentClientName = Replace(Cells(currentRangeStart, 1).Value, " ", "_") 'assuming client name is in column A

    Dim numRanges As Long
    Dim rangeList() As String
    Dim i As Long
    Dim RangeName As String
    Dim currentRangeIndex As Long
    currentRangeIndex = 0
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' Find the last row with data in Column A
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")

    For i = 1 To lastRow
        If Cells(i, 1).Interior.ColorIndex = 55 Then 'assuming colorindex 55 represents the start of a new range
            'create named range
            Dim currentRangeEnd As Long
            currentRangeEnd = i - 1
            If currentRangeEnd - currentRangeStart > 0 Then 'check if range has at least 2 rows
                RangeName = currentClientName
                ' Replace spaces and invalid characters with an underscore
                RangeName = Replace(RangeName, " ", "_")
                RangeName = Replace(RangeName, "&", "_")
                RangeName = Replace(RangeName, "-", "_")
                RangeName = Replace(RangeName, "/", "_")
                RangeName = Replace(RangeName, "?", "_")
                RangeName = Replace(RangeName, "[", "_")
                RangeName = Replace(RangeName, "]", "_")
                RangeName = Replace(RangeName, "'", "_")
                RangeName = Replace(RangeName, "(", "_")
                RangeName = Replace(RangeName, ")", "_")
                Dim RngRange As Range
                Set RngRange = Range(Cells(currentRangeStart, 1), Cells(currentRangeEnd, 3)) 'assuming data is in columns A to C
                RngRange.Select
                If Not RangeExists(RangeName) Then
                    ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=RngRange
                    'If you receive an error in this line, it might be that there is a charcter in a name that is not listed in the Replace arguments above i.e. go to the line where it stops and look at the value in the cell, search the character and insert a replace case for that
                End If
                numRanges = numRanges + 1
                ReDim Preserve rangeList(currentRangeIndex)
                rangeList(currentRangeIndex) = RangeName
                currentRangeIndex = currentRangeIndex + 1
                Dim k As Long
                For k = 1 To currentRangeEnd
                    If Cells(k, 1).Interior.ColorIndex = 37 And Not Cells(k, 1).Value = "Liquidités" Then 'assuming colorindex 37 represents the start of a subrange for the current client
                        Debug.Print "ColorIndex: " & Cells(k, 1).Interior.ColorIndex
                        Dim subRangeStart As Long
                        Dim SubRangeName As String
                        Dim subrangeList() As String
                        Dim subRangeIndex As Long
                        Dim numsubRanges As Long
                        subRangeIndex = 0
                        subRangeStart = k
                        Dim subRangeEnd As Long
                        subRangeEnd = GetSubRangeEnd(subRangeStart, currentRangeEnd)
                ' update sub range start to exclude client name row
                        subRangeStart = subRangeStart
                        If subRangeEnd - subRangeStart > 0 Then ' check if sub range has at least 1 row
                            ' create named range
                            SubRangeName = currentClientName
                            SubRangeName = Replace(SubRangeName, " ", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "&", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "-", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "/", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "?", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "[", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "]", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "'", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, "(", "_") & subRangeIndex
                            SubRangeName = Replace(SubRangeName, ")", "_") & subRangeIndex
                            Dim SubRngRange As Range
                            Set SubRngRange = Range(Cells(subRangeStart, 1), Cells(subRangeEnd, 3)) ' assuming data is in columns A to C
                            SubRngRange.Select
                            If Not SubRangeExists(SubRangeName) Then
                                ThisWorkbook.Names.Add Name:=SubRangeName, RefersTo:=SubRngRange
                            End If
                            numsubRanges = numsubRanges + 1
                            ReDim Preserve subrangeList(subRangeIndex)
                            subrangeList(subRangeIndex) = SubRangeName
                            subRangeIndex = subRangeIndex + 1
                        End If
                    End If
                Next k
            End If
            'update current range start and client name
            currentRangeStart = i
            currentClientName = Cells(currentRangeStart, 1).Value
        End If
        Dim i As Long
        For y = 1 To numRanges
            ' Your code here
            
            ' Add this line after every 50 ranges
            If y Mod 50 = 0 Then Debug.Print "Processed " & y & " ranges"
            
    Next i
    
    ' create last named range
    Dim lastRangeEnd As Long
    lastRangeEnd = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRangeEnd - currentRangeStart > 0 Then ' check if range has at least 2 rows
        Dim lastRangeName As String
        lastRangeName = currentClientName
        Dim lastRngRange As Range
        Set lastRngRange = ws.Range(ws.Cells(currentRangeStart, 1), ws.Cells(lastRangeEnd, 3)) ' assuming data is in columns A to C
        If Not RangeExists(lastRangeName) Then
            ThisWorkbook.Names.Add Name:=lastRangeName, RefersTo:=lastRngRange
            numRanges = numRanges + 1
            ReDim Preserve rangeList(0 To numRanges - 1)
            rangeList(numRanges - 1) = lastRangeName
        End If
    End If

    ' output number of named ranges created
    MsgBox "Number of named ranges created: " & numRanges
    MsgBox "Number of named subranges created: " & subnumRanges

End Sub
    
'Find duplicated ranges and jump them
Function RangeExists(RangeName As String) As Boolean
    Dim lo As ListObject
    For Each lo In ActiveSheet.ListObjects
        If lo.Name = RangeName Then
            RangeExists = True
            Exit Function
        End If
    Next lo
    RangeExists = False
End Function

Public Function GetSubRangeEnd(ByVal subRangeStart As Long, ByVal lastRow As Long) As Long
    Dim currentRow As Long
    Dim currentCol As Integer
    Dim lastCol As Integer
    
    currentRow = subRangeStart
    currentCol = 1 ' assuming data starts in column A
    lastCol = 3 ' assuming data ends in column C
    
    'Find the last row of the subrange
    Do While Not IsEmpty(Cells(currentRow, currentCol))
        If currentRow > lastRow Then Exit Do
        currentRow = currentRow + 1
    Loop
    
    'Find the last column of the subrange
    Do While Not IsEmpty(Cells(subRangeStart, lastCol + 1))
        lastCol = lastCol + 1
    Loop
    
    GetSubRangeEnd = Cells(currentRow - 1, lastCol).Row
End Function


'Find duplicated ranges and jump them
Function SubRangeExists(SubRangeName As String) As Boolean
    Dim lo As ListObject
    For Each lo In ActiveSheet.ListObjects
        If lo.Name = SubRangeName Then
            SubRangeExists = True
            Exit Function
        End If
    Next lo
    SubRangeExists = False
End Function

Input range and created named ranges:

Code:

Option Explicit

Sub Testbook1()
    Dim ws As Worksheet, colRanges As Collection, rng As Range
    Dim lr As Long, colSubRanges As Collection, subRng As Range
    Dim client As String, i As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'for example
    lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
    
    'first collect all the main ranges
    Set colRanges = SubRanges(ws.Range("A1:C" & lr), 55)
    
    For Each rng In colRanges
        If rng.Rows.Count > 1 Then 'at least 2 rows?
            Debug.Print "Main range: " & rng.Address
            client = CleanName(rng.Cells(1).Value) ' "clean" client name
            
            AddNamedRange client, rng
            
            Set colSubRanges = SubRanges(rng, 37) 'get subranges within this range
            i = 0
            For Each subRng In colSubRanges
                Debug.Print , "Subrange: " & subRng.Address
                i = i + 1
                AddNamedRange client & "_C" & i, subRng
            Next subRng
        End If
    Next rng

End Sub

'Return a collection of any ranges within `rngData` which are headed
'  by a cell with a given fill color index `clrIndex` in the first column
Function SubRanges(rngData As Range, clrIndex As Long) As Collection
    Dim colRanges As New Collection, c As Range, rng As Range, ws As Worksheet
    Dim numCols As Long, col As Range
    
    numCols = rngData.Columns.Count
    Set ws = rngData.Worksheet
    Set col = rngData.Columns(1)
    For Each c In col.Cells
        If c.Interior.ColorIndex = clrIndex Then
            If Not rng Is Nothing Then 'previous range?
                colRanges.Add ws.Range(rng, c.Offset(-1)).Resize(, numCols)
            End If
            Set rng = c
        End If
    Next c
    If Not rng Is Nothing Then 'close any open range
        colRanges.Add ws.Range(rng, col.Cells(col.Cells.Count)).Resize(, numCols)
    End If
    Set SubRanges = colRanges
End Function

'Create a named range if it doesn't already exist
Sub AddNamedRange(RangeName As String, rng As Range)
    Dim nm As Name, wb As Workbook
    Set wb = rng.Worksheet.Parent
    On Error Resume Next
    Set nm = wb.Names(RangeName)
    On Error GoTo 0
    If nm Is Nothing Then
        wb.Names.Add Name:=RangeName, RefersTo:=rng
    End If
End Sub

'replace a set of characters with underscore
Function CleanName(s As String) As String
    Const REM_CHARS As String = " &-/?[]'()"
    Dim i As Long
    CleanName = s
    For i = 1 To Len(REM_CHARS)
        CleanName = Replace(CleanName, Mid(REM_CHARS, i, 1), "_")
    Next i
End Function

Debug.Print output:

Main range: $A$1:$C$14
              Subrange: $A$2:$C$8
              Subrange: $A$9:$C$13
              Subrange: $A$14:$C$14
Main range: $A$15:$C$21
              Subrange: $A$16:$C$17
              Subrange: $A$18:$C$20
              Subrange: $A$21:$C$21
Main range: $A$22:$C$26
              Subrange: $A$23:$C$23
              Subrange: $A$24:$C$26