PDA

View Full Version : help edit vba code - 2003 column limit



bobby999
11-03-2008, 07:40 AM
: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!



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