help edit vba code - 2003 column limit

:dunno

the code looks at between 2-4 columns of data which have relationships and creates defined lists to use in listboxes.

The problem is some of these lists ( normally the first one but potentially one or two thers) is more than 256 names ( the named lists are creatd horizontally.)

I cant have all of these list created vertically as there WILL be more than 256 lists.

SO my idea is :

Once data is added to the arrays ( i think this is done first)
Order arrays by number of elements
If array > 240 elements
Then create named list vertically ( then move to next column)
ELse
create rest or named list horizontally.


Pleas help me edit the code below:
hopefully you understand what i mean, please just ask for any further clarification!

Code:

---

Sub Create_Names()
Dim rList As Range, rCell As Range, oDic As Object, oDic1 As Object
Dim lColumns As Long, lRow As Long, lOffset As Long
Dim lOutColumn As Long, sRoot As String
 
Set rList = Range("A2", Range("A" & Rows.Count).End(xlUp))
lColumns = rList.CurrentRegion.Columns.Count
lOutColumn = rList.Column + lColumns + 2        ' writes the result 2 columns to the right of the table
sRoot = "TEST"                                ' name of the root
 
' store the info
Set oDic = CreateObject("scripting.Dictionary")
oDic.CompareMode = vbTextCompare
For Each rCell In rList
    Set oDic1 = oDic
    For lOffset = 0 To lColumns - 1
        If rCell.Offset(, lOffset).Value = "" Then Exit For
        If Not oDic1.exists(rCell.Offset(, lOffset).Value) Then
            oDic1.Add rCell.Offset(, lOffset).Value, CreateObject("Scripting.Dictionary")
            oDic1(rCell.Offset(, lOffset).Value).CompareMode = vbTextCompare
        End If
        Set oDic1 = oDic1(rCell.Offset(, lOffset).Value)
    Next lOffset
Next rCell
 
' Create the root and the names
Set oDic1 = CreateObject("scripting.dictionary")
oDic1.Add sRoot, oDic
Call CreateNames1(oDic1, lRow, lOutColumn, "")
 
End Sub
 
Sub CreateNames1(ByVal oDic As Object, lRow As Long, lOutColumn As Long, ByVal sPrefix As String)
Dim vkey As Variant, sName As String
 
With oDic
    ' create the names for this level
    For Each vkey In .keys
        If oDic(vkey).Count > 0 Then
            sName = "_" & Replace(Replace(Replace(Replace(Replace(vkey, " ", "_"), "/", "_"), "-", "_"), "&", "_"), "~", "")
            lRow = lRow + 1
            Cells(lRow, lOutColumn) = sPrefix & sName
            Cells(lRow, lOutColumn + 1).Resize(, .Item(vkey).Count) = .Item(vkey).keys
            Names.Add sPrefix & sName, Cells(lRow, lOutColumn + 1).Resize(, .Item(vkey).Count)
        End If
    Next vkey
     
    ' create the names for the sublevels
    For Each vkey In .keys
        If oDic(vkey).Count > 0 Then
            sName = "_" & Replace(Replace(Replace(Replace(Replace(vkey, " ", "_"), "/", "_"), "-", "_"), "&", "_"), "~", "")
            Call CreateNames1(oDic(vkey), lRow, lOutColumn, sPrefix & sName)
        End If
    Next vkey
End With
End Sub

---