Reg:Macro needed to pick up only distinct values but it picks up allthe values

[anshu minocha]

Hi all,
I have used the following code to lookup values for ID in
colB and for that value gives all the values of the WRnbr in colC ,
but I need the code to return only distinct values for the WR#,please
advise of the modifications.ANy help would be appreciated:

Option Explicit
Sub FindWRNbr()
Dim ws1 As Worksheet, ws2 As Worksheet, a As Long, SPMID As String
Dim c As Range, firstaddress As String, Hold As String
Set ws1 = Sheets("SPM_id_view")
Set ws2 = Sheets("Dragoni_owned")
Application.ScreenUpdating = False
With ws1
For a = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Step 1
Hold = ""
SPMID = .Cells(a, 2).Value
With ws2.Columns(34)

Set c = .Find(SPMID, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Hold = Hold & c.Offset(, -33).Value & "#"
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
If Right(Hold, 1) = "#" Then
Hold = Left(Hold, Len(Hold) - 1)
ws1.Cells(a, 3) = Hold
End If
Next a
End With
Application.ScreenUpdating = True
ws1.Select
End Sub

 

[Dave Peterson]

John Walkenbach shares how to do this -- but with a listbox.
http://spreadsheetpage.com/index.php/file/unique_items_in_a_listbox

Another option would be to use data|filter|advanced filter (to a different
sheet) to get that list of unique items. Then cycle through that range.

 

[anshu minocha]

Thankyou Dave, but I'm creating the list box in sheet1 from the values
in colC of sheet2...
Can you suggest is this possible with John's code with some
modifications?

Thanks
John's code
Option Explicit
' This example is based on a tip by J.G. Hussey,
' published in "Visual Basic Programmer's Journal"

Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item

' The items are in A1:A105
Set AllCells = Range("A1:A105")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a
string
Next Cell

' Resume normal error handling
On Error GoTo 0

' Update the labels on UserForm1
With UserForm1
.Label1.Caption = "Total Items: " & AllCells.Count
.Label2.Caption = "Unique Items: " & NoDupes.Count
End With

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

' Add the sorted, non-duplicated items to a ListBox
For Each Item In NoDupes
UserForm1.ListBox1.AddItem Item
Next Item

' Show the UserForm
UserForm1.Show
End Sub

 

[Dave Peterson]

One change is to make sure you pick up the values from the sheet you want--in
the range you want.

Set AllCells = Range("A1:A105
becomes:

with worksheets("Sheet2")
Set AllCells = .Range("c1",.cells(.rows.count,"C").end(xlup))
end with

 

[anshu minocha]

Thankyou Dave worked Great!!!!