List unique items

[Robert H]

I'm trying to look at a works sheet and list all the unique items
found on that sheet in another sheet. The source sheet has around 50
columns of varying length. The following codes was slightly modified
from http://www.ozgrid.com/forum/showthread.php?t=39790 which comes
close to doing what I need. I need the area analyzed to be dynamic so
I added counting the used columns and rows (nCol and nRow) and tried
to work them into the code. the column count was pretty easy to work
in but the row count which seems to correspond to the upper bound of
"y" is not responding well to my attempts. Part of the problem is my
ignorance of the dictionary script thing that is implemented in the
code.

Any help will be appreciated.

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dic As Object, w, y
Dim a, i As Long
Dim nCol As Integer
Dim nRows As Integer

Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Sheets("List") ' alter if needed


With ws1.Range("a1").CurrentRegion
a = .Value
End With

nCol = ws1.UsedRange.Columns.Count
nRows = ws1.UsedRange.Rows.Count


For i = LBound(a, 1) To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
If Not dic.exists(a(i, 1)) Then
ReDim w(1 To nCol)
For ii = 1 To nCol
w(ii) = a(i, ii)
Next
dic.Add a(i, 1), w
Else
w = dic(a(i, 1)): w(nCol) = Val(w(nCol)) + Val(a(i,
nCol))
dic(a(i, 1)) = w
End If
End If
Next
y = dic.items: Set dic = Nothing
On Error Resume Next
Set ws2 = Sheets("Summary")
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = ("Summary")
End If
On Error GoTo 0
With ws2.Range("a1")
.CurrentRegion.ClearContents
With .Range("a1")
For i = LBound(y) To UBound(y)
.Offset(i).Resize(, UBound(y(i))) = y(i)
Next
End With
End With
Set ws1 = Nothing: Set ws2 = Nothing
Erase a, y, w
End Sub

 

[marcus]

Hi Robert

Remove these lines from your procedure

' w = dic(a(i, 1)): w(nCol) = Val(w(nCol)) + Val(a(i,
nCol))
' dic(a(i, 1)) = w

They seem to be getting in the road of the efficient running of your
code. In testing the a = .value picks up the variable row length so
you don't need this line either

nRows = ws1.UsedRange.Rows.Count

I sent up a range of varying lengths and column widths, ran several
tests and the code seemed to cope well with this provided the above
was removed. However my test data may look completely different to
yours.

Take care

Marcus

 

[Robert H]

Thanks Marcus I have modified my code as you suggested but in the
results the number of rows in all columns is 4 which is the number of
rows in the first column of the source data.

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dic As Object, w, y
Dim a, i As Long
Dim nCol As Integer
'Dim nRows As Integer

Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Sheets("List") ' alter if needed


With ws1.Range("a1").CurrentRegion
a = .Value
End With

nCol = ws1.UsedRange.Columns.Count
'nRows = ws1.UsedRange.Rows.Count


For i = LBound(a, 1) To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
If Not dic.exists(a(i, 1)) Then
ReDim w(1 To nCol)
For ii = 1 To nCol
w(ii) = a(i, ii)
Next
dic.Add a(i, 1), w
'Else
'w = dic(a(i, 1)): w(nCol) = Val(w(nCol)) + Val(a(i,
nCol))
'dic(a(i, 1)) = w
End If
End If
Next
y = dic.items: Set dic = Nothing
On Error Resume Next
Set ws2 = Sheets("Summary")
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = ("Summary")
End If
On Error GoTo 0
With ws2.Range("a1")
.CurrentRegion.ClearContents
With .Range("a1")
For i = LBound(y) To UBound(y)
.Offset(i).Resize(, UBound(y(i))) = y(i)
Next
End With
End With
Set ws1 = Nothing: Set ws2 = Nothing
Erase a, y, w
End Sub

 

[Robert H]

Thanks Marcus I have modified my code as you suggested but in the
results the number of rows in all columns is 4 which is the number of
rows in the first column of the source data.

However, what you say does make sense. I set watches on several of the
variables and "a" has 30 items, which is the maximum number of rows in
my data and "w" has 47 items which is the number of columns. I just
need to figure out why it stops populating the summary sheet after 4
rows for all columns.

Its a good puzzle, thanks for the help.
Robert


Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dic As Object, w, y
Dim a, i As Long
Dim nCol As Integer
'Dim nRows As Integer

Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Sheets("List") ' alter if needed

With ws1.Range("a1").CurrentRegion
a = .Value
End With

nCol = ws1.UsedRange.Columns.Count
'nRows = ws1.UsedRange.Rows.Count

For i = LBound(a, 1) To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
If Not dic.exists(a(i, 1)) Then
ReDim w(1 To nCol)
For ii = 1 To nCol
w(ii) = a(i, ii)
Next
dic.Add a(i, 1), w
'Else
'w = dic(a(i, 1)): w(nCol) = Val(w(nCol)) + Val(a(i,
nCol))
'dic(a(i, 1)) = w
End If
End If
Next
y = dic.items: Set dic = Nothing
On Error Resume Next
Set ws2 = Sheets("Summary")
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = ("Summary")
End If
On Error GoTo 0
With ws2.Range("a1")
.CurrentRegion.ClearContents
With .Range("a1")
For i = LBound(y) To UBound(y)
.Offset(i).Resize(, UBound(y(i))) = y(i)
Next
End With
End With
Set ws1 = Nothing: Set ws2 = Nothing
Erase a, y, w
End Sub


- Hide quoted text -
- Show quoted text -

Hi Robert

Remove these lines from your procedure

' w = dic(a(i, 1)): w(nCol) = Val(w(nCol)) + Val(a(i,
nCol))
' dic(a(i, 1)) = w

They seem to be getting in the road of the efficient running of your
code. In testing the a = .value picks up the variable row length so
you don't need this line either

nRows = ws1.UsedRange.Rows.Count

I sent up a range of varying lengths and column widths, ran several
tests and the code seemed to cope well with this provided the above
was removed. However my test data may look completely different to
yours.

Take care

Marcus

 

[Robert H]

It seems the problem prior at step " y = dic.items" at that point
dic.items "count" is 4 which is odd because dic is created from "a"
which is 1-30, 1-47. It should be 30.