Updating collection values to use as summary

[Dolemite]

I have a worksheet with 2 columns, the first column contains a quantity,
and second contains a "Unit ID" (string). Any Unit can appear several
times throughout the list. I am wanting to generate another Summary
List and I figured that a collection would be a good way to go, now I
am wondering if this is correct.

I have written a simple test before I actually try to apply it to my
real project, and it just isn't behaving like I expected it to.
Basically I am using the collection to store all the unique unit id's.
The code runs through the whole list and adds the unique id's to the
collection. My hope was that if my script came to a unitid that
already existed in the collection, I could store the current quantity
in a variable, read in the quantity on the new instance, and add it to
the old one and save this quantity in the collection, so I would have a
total for that unit id. Well, when I do this it actually updates the
value on the worksheet as though the collection is directly linked to
the cell. Is this how collections work or am I am just using them
incorrectly. If there is a better way to accomplish this please feel
free to inform me.

using the following values:
1 a
1 a
1 b
1 c
1 c

after I run the script I get this

2 a a 1
1 a a 2
1 b b 1
2 c c 1
1 c c 2

The second group of numbers is just what I am using to see what the
collection has in it.

here is my script...

Private Sub CommandButton1_Click()

Dim foundend As Boolean
Dim ws As Sheet1
Set ws = Worksheets(1)
Dim unitsum As Collection
Set unitsum = New Collection
r = 1
ucol = "B"
While Not foundend
If Not (ws.Range(ucol & r).Text) = "" Then
On Error Resume Next
unitsum.Add ws.Range("A" & r), ws.Range(ucol & r)
'vbNullString , CStr(Range("d" & i + first).Value)
If Err.Number <> 0 Then
oqty = unitsum.Item(ws.Range(ucol & r).Value)
unit = ws.Range("B" & r).Text
unitsum.Item(unit) = oqty + ws.Range("A" & r)

End If
ws.Range("D" & r) = ws.Range(ucol & r).Value
ws.Range("E" & r) = unitsum(ws.Range(ucol & r))
Else: foundend = True
End If
r = r + 1
Wend
Set Collection = Nothing

End Sub

 

[Guest]

For unique item you are better off with a dictionary object than a
collection. I have code for that if you want, but why not just use a pivot
table. That would be a whole pile easier and efficient than the code.

 

[Dolemite]

First of all thanks for the response...

Well, I have never used a dictionary object, but I am more than willing
to take a look at them and see how they work and what they can do. As
far as the pivot tables are concerned, this is only one portion of a
much larger project, an I was hoping to keep the intermediate steps (as
this one is) out of the worksheets. Also, the length of the list will
always be different, and I have never messed with dynamic ranges for
pivot tables. But if it can be done, once again, I am open to try it.
That is why I wanted to post it the board so that I could get some ideas
from others who may have done this same thing.

And yes I would like to see your code.

 

[Guest]

You need to reference the project to the microsoft scripting runtime to make
this code work...

Select a range of cells and then just run the code. It will create a new
sheet with all of the unique items from the selected range.

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

Application.ScreenUpdating = False
'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
If rngToSearch Is Nothing Then Set rngToSearch = ActiveCell

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) And cell.Value <> Empty Then
'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
Application.ScreenUpdating = True
End Sub