Hi,

I'm trying to create a collection from a given range of cells. The
code seems to run but the collection I try to create (in this case
called "MainCategory") has no data in it. Can anybody help?

Thanks,
Derek


Public MainCategory As New Collection
Dim AllCells As Range

Sub Test()
<code
Set AllCells = Range(Range("top_label").Offset(1, 0),
Rang("top_label").End(xlDown))

' Create a new collection
Set MainCategory = CreateCollection(AllCells)
End Sub

Function CreateCollection(AllCells As Range) As Collection
Dim Cell
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
CreateCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
End Function

Derek,
I think the source of your problem is defining the Function as a collection
type. (I beleive, -MVPs please clarify) that this refers to a pre-f=defined
collection in VB, as opposed to a "New", or user-defined, collection).

Secondly, the "On Error Resume Next" statement in your function (which is
rightly there to deal with duplicate entries) masks the fact that the
CreateCollection will not accept any new members to be added to it (check
the locals window).

So, the workaround (with the benefit of a quick test), us to use a
subroutine as follows:

Public MainCategory As New Collection
Dim AllCells As Range

Sub Test()

Set AllCells = Sheets("Sheet1").Range("DataRange") '(My data
source used to test)
' Create a new collection
Call CreateNewCollection(AllCells, MainCategory)

End Sub


Sub CreateNewCollection(AllCells As Range, xcNew As Collection)
Dim Cell
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
xcNew.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
End Sub

Alex

By the way, I like to use the prefix "xc" on all my userdefined collections.
I seems to highlight them well in the code.

"Derek Gadd" wrote in message
om...
Hi,

I'm trying to create a collection from a given range of cells. The
code seems to run but the collection I try to create (in this case
called "MainCategory") has no data in it. Can anybody help?

Thanks,
Derek


Public MainCategory As New Collection
Dim AllCells As Range

Sub Test()
<code
Set AllCells = Range(Range("top_label").Offset(1, 0),
Rang("top_label").End(xlDown))

' Create a new collection
Set MainCategory = CreateCollection(AllCells)
End Sub

Function CreateCollection(AllCells As Range) As Collection
Dim Cell
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
CreateCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
End Function

Derek..

For all functions is best to set a temp variable, then work on that
inside the function and at the end return the variable.

I've also added the option to return the collection sorted :)

Option Explicit
Option Compare Text

Sub Test()
Dim AllCells As Range
Dim mainCategory(1 To 3) As Collection
Dim i As Integer
Set AllCells = Range(Range("top_label").Offset(1, 0), Range
("top_label").End(xlDown))
' Create a few collections
Set mainCategory(1) = CreateCollection(AllCells)
Set mainCategory(2) = CreateCollection(AllCells, xlAscending)
Set mainCategory(3) = CreateCollection(AllCells, xlDescending)
End Sub

Function CreateCollection(AllCells As Range, Optional Sorted As
XlSortOrder = 0) As Collection
Dim Coll As New Collection
Dim Cell As Range
Dim n As Long
'note: option compare must be set to TEXT

On Error Resume Next
'Add a dummy to populate collection
Coll.Add Choose(Sorted, -1E+99, String(99, "z"))
For Each Cell In AllCells
With Cell
Select Case Sorted
Case xlAscending
For n = 1 To Coll.Count
If .Value < Coll(n) Then Exit For
Next
Case xlDescending
For n = 1 To Coll.Count
If .Value Coll(n) Then Exit For
Next
Case Else
n = Coll.Count + 1
End Select
Coll.Add .Value, CStr(.Value), , n - 1
End With
Next
'Remove dummy
Coll.Remove 1
'Return the result
Set CreateCollection = Coll
End Function



keepITcool

< email : keepitcool chello nl (with @ and .)
< homepage: http://members.chello.nl/keepitcool


(Derek Gadd) wrote:

Hi,

I'm trying to create a collection from a given range of cells. The
code seems to run but the collection I try to create (in this case
called "MainCategory") has no data in it. Can anybody help?

Thanks,
Derek


Public MainCategory As New Collection
Dim AllCells As Range

Sub Test()
<code
Set AllCells = Range(Range("top_label").Offset(1, 0),
Rang("top_label").End(xlDown))

' Create a new collection
Set MainCategory = CreateCollection(AllCells)
End Sub

Function CreateCollection(AllCells As Range) As Collection
Dim Cell
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
CreateCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
End Function

KeepitCool,

VERY nice solution. Thanks for a very useful post.

Alex

"keepitcool" wrote in message
...
Derek..

For all functions is best to set a temp variable, then work on that
inside the function and at the end return the variable.

I've also added the option to return the collection sorted :)

Option Explicit
Option Compare Text

Sub Test()
Dim AllCells As Range
Dim mainCategory(1 To 3) As Collection
Dim i As Integer
Set AllCells = Range(Range("top_label").Offset(1, 0), Range
("top_label").End(xlDown))
' Create a few collections
Set mainCategory(1) = CreateCollection(AllCells)
Set mainCategory(2) = CreateCollection(AllCells, xlAscending)
Set mainCategory(3) = CreateCollection(AllCells, xlDescending)
End Sub

Function CreateCollection(AllCells As Range, Optional Sorted As
XlSortOrder = 0) As Collection
Dim Coll As New Collection
Dim Cell As Range
Dim n As Long
'note: option compare must be set to TEXT

On Error Resume Next
'Add a dummy to populate collection
Coll.Add Choose(Sorted, -1E+99, String(99, "z"))
For Each Cell In AllCells
With Cell
Select Case Sorted
Case xlAscending
For n = 1 To Coll.Count
If .Value < Coll(n) Then Exit For
Next
Case xlDescending
For n = 1 To Coll.Count
If .Value Coll(n) Then Exit For
Next
Case Else
n = Coll.Count + 1
End Select
Coll.Add .Value, CStr(.Value), , n - 1
End With
Next
'Remove dummy
Coll.Remove 1
'Return the result
Set CreateCollection = Coll
End Function



keepITcool

< email : keepitcool chello nl (with @ and .)
< homepage: http://members.chello.nl/keepitcool


(Derek Gadd) wrote:

Hi,

I'm trying to create a collection from a given range of cells. The
code seems to run but the collection I try to create (in this case
called "MainCategory") has no data in it. Can anybody help?

Thanks,
Derek


Public MainCategory As New Collection
Dim AllCells As Range

Sub Test()
<code
Set AllCells = Range(Range("top_label").Offset(1, 0),
Rang("top_label").End(xlDown))

' Create a new collection
Set MainCategory = CreateCollection(AllCells)
End Sub

Function CreateCollection(AllCells As Range) As Collection
Dim Cell
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
CreateCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
End Function

Using your original construct, these modifications worked:

Public MainCategory As Variant

Sub Test()
Dim AllCells As Range
' <code
Set AllCells = Range(Range("top_label"). _
Offset(1, 0), Range("top_label").End(xlDown))

' Create a new collection
Set MainCategory = CreateCollection(AllCells)
For Each itm In MainCategory
Debug.Print itm
Next
End Sub

Function CreateCollection(AllCells As Range) As Variant
Dim Cell As Range
Dim myColl As New Collection
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
myColl.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
Set CreateCollection = myColl
End Function


--
Regards,
Tom Ogilvy

Derek Gadd wrote in message
om...
Hi,

I'm trying to create a collection from a given range of cells. The
code seems to run but the collection I try to create (in this case
called "MainCategory") has no data in it. Can anybody help?

Thanks,
Derek


Public MainCategory As New Collection
Dim AllCells As Range

Sub Test()
<code
Set AllCells = Range(Range("top_label").Offset(1, 0),
Rang("top_label").End(xlDown))

' Create a new collection
Set MainCategory = CreateCollection(AllCells)
End Sub

Function CreateCollection(AllCells As Range) As Collection
Dim Cell
'Prevents errors from trying to have duplicate entries
On Error Resume Next
For Each Cell In AllCells
CreateCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
End Function