Duplicate value are not being removed

[Corey]

The following code is suppose to remove the duplicate values, but it is not.

Listbox1.value when selected populates the listbox2

Is use the same code to initialise the form and populate Listbox1 which DOES remove any duplicates.
But, the below code does not.
Am i missing something obvious ?

Private Sub ListBox1_Change()
Application.ScreenUpdating = False
If ListBox2.ListCount > 0 Then ListBox2.Clear
Dim LastCell As Long
Dim myrow As Long
Dim NoDupes As Collection
On Error Resume Next
LastCell = Worksheets("Data2").Cells(Rows.Count, "C").End(xlUp).Row
With ActiveWorkbook.Worksheets("Data2")
.Select
Set NoDupes = New Collection
For myrow = 1 To LastCell
If ListBox1.Value = .Cells(myrow, 2).Value And .Cells(myrow, 2) <> "" Then
NoDupes.Add .Cells(myrow, 3).Value, CStr(.Cells(myrow, 3).Value)
If Err.Number = 0 Then
If .Cells(myrow, 3) <> "" And .Cells(myrow, 2) = ListBox1.Value Then
ListBox2.AddItem .Cells(myrow, 3) ' <=== DUPLICATES are still DISPLAYED
End If
Else
Err.Clear
End If
End If
Next
End With
Sheets("POST Project Report").Select
Application.ScreenUpdating = True
End Sub

 

[Guest]

I'm see ListBox1_Change and you say you are trying to apply this to ListBox2?
Or am I just confused?

 

[Corey]

When a slection is made to Listbox1, Listbox2 is then Poplulated with values.


Corey...

I'm see ListBox1_Change and you say you are trying to apply this to ListBox2?
Or am I just confused?

 

[Guest]

Maybe I'm just reading the code wrong, but I don't see anything in the
snippet you posted that would prevent duplicates. The If statements could
evaluate to true as far as I can tell, which means the item gets added.

 

[Doug Glancy]

Corey,

I didn't actually run this so not sure if it will work. But a couple of
things:

You only want to set the collection once. As you add to it, if it's a dupe
that will generate an error, which will tell you not add it. So you want to
bracket the adding with your 2 On Error statements.

I've used this technique a few times. I always fill the whole collection
first and then write it to the range. Anyways this might at least get you
closer:

Private Sub ListBox1_Change()
Dim LastCell As Long
Dim myrow As Long
Dim NoDupes As Collection

Set NoDupes = New Collection
Application.ScreenUpdating = False
If ListBox2.ListCount > 0 Then ListBox2.Clear
LastCell = Worksheets("Data2").Cells(Rows.Count, "C").End(xlUp).Row
With ActiveWorkbook.Worksheets("Data2")
For myrow = 1 To LastCell
If ListBox1.Value = .Cells(myrow, 2).Value And .Cells(myrow, 2) <> ""
Then
On Error Resume Next
NoDupes.Add .Cells(myrow, 3).Value, CStr(.Cells(myrow, 3).Value)
If Err.Number = 0 Then
If .Cells(myrow, 3) <> "" And .Cells(myrow, 2) = ListBox1.Value Then
ListBox2.AddItem .Cells(myrow, 3) ' <=== DUPLICATES are still
DISPLAYED
On Error Goto 0
End If
End If
Next
End With
Sheets("POST Project Report").Select
Application.ScreenUpdating = True
End Sub

 

[Corey]

Thnak You Doug your advice is appreciated.

Working greate now, thank You


Corey....


Corey,

I didn't actually run this so not sure if it will work. But a couple of
things:

You only want to set the collection once. As you add to it, if it's a dupe
that will generate an error, which will tell you not add it. So you want to
bracket the adding with your 2 On Error statements.

I've used this technique a few times. I always fill the whole collection
first and then write it to the range. Anyways this might at least get you
closer:

Private Sub ListBox1_Change()
Dim LastCell As Long
Dim myrow As Long
Dim NoDupes As Collection

Set NoDupes = New Collection
Application.ScreenUpdating = False
If ListBox2.ListCount > 0 Then ListBox2.Clear
LastCell = Worksheets("Data2").Cells(Rows.Count, "C").End(xlUp).Row
With ActiveWorkbook.Worksheets("Data2")
For myrow = 1 To LastCell
If ListBox1.Value = .Cells(myrow, 2).Value And .Cells(myrow, 2) <> ""
Then
On Error Resume Next
NoDupes.Add .Cells(myrow, 3).Value, CStr(.Cells(myrow, 3).Value)
If Err.Number = 0 Then
If .Cells(myrow, 3) <> "" And .Cells(myrow, 2) = ListBox1.Value Then
ListBox2.AddItem .Cells(myrow, 3) ' <=== DUPLICATES are still
DISPLAYED
On Error Goto 0
End If
End If
Next
End With
Sheets("POST Project Report").Select
Application.ScreenUpdating = True
End Sub