# Compare Listbox values with Collection values

Discussion in 'Microsoft Excel Programming' started by Stuart, Sep 19, 2003.

1. ### StuartGuest

Say frm1.lb1.Column(1) and Column(2) are populated
from a range in a worksheet.
Say a Collection has been built of unique and sorted
values.

Can I compare the values in the Collection with the
values in Column(1) of the listbox such that:

a) if the the value exists in the lb, then ok.
b) if it doesn't, then add it to the lb.
c) if there's a value in the lb that's not in the Collection,
then remove it (and the lb.Column(2) value from the lb.

Regards.

---
Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.518 / Virus Database: 316 - Release Date: 11/09/2003

Stuart, Sep 19, 2003

2. ### Tom OgilvyGuest

Put this is an empty workbook with a form named Frm1 having a listbox named
lb1 and a commandbutton named commandbutton1.

On sheet1, put in a list of sorted values in B3:B24 and corresponding names
in C3:C24. In D324 put in sorted or unsorted entries similar to those in

Execute AA_showform and then press Commandbutton1 to adjust the list.

In a general module:
Option Explicit

Sub AA_showform()
frm1.Show
End Sub

Sub Tester3()
Dim NoDupes As New Collection
Dim rng As Range
Dim i As Long
Dim vVal As Variant
Dim itm As Variant
Dim res As Variant
Dim varr2 As Variant, cnt As Long
Dim varr As Variant, varr1 As Variant

' set up a collection
Set rng = Worksheets("sheet1").Range("D324")
RemoveDuplicates rng, NoDupes
' End Setup a collection

With frm1.lb1
cnt = .ListCount
For i = .ListCount - 1 To 0 Step -1
vVal = Empty
On Error Resume Next
vVal = NoDupes(.List(i, 0))
' Debug.Print i, vVal
On Error GoTo 0
If IsEmpty(vVal) Then
.RemoveItem i
cnt = cnt - 1
End If
Next
varr = .List
ReDim varr1(1 To cnt, 1 To 1)
For i = 1 To cnt
varr1(i, 1) = .List(i - 1, 0)
Next
ReDim varr2(1 To 2, 1 To 1)
For Each itm In NoDupes
res = Application.Match(itm, varr1, 1)
If IsError(res) Then
varr2(1, UBound(varr2, 2)) = itm
varr2(2, UBound(varr2, 2)) = -1
ReDim Preserve varr2(1 To 2, 1 To _
UBound(varr2, 2) + 1)
Else
If itm <> varr1(res, 1) Then
varr2(1, UBound(varr2, 2)) = itm
varr2(2, UBound(varr2, 2)) = res
ReDim Preserve varr2(1 To 2, 1 To _
UBound(varr2, 2) + 1)
End If
End If

Next
For i = UBound(varr2, 2) - 1 To 1 Step -1
If varr2(2, i) = -1 Then
Else
End If
Next
End With
End Sub

Sub RemoveDuplicates(rng As Range, NoDupes As Collection)
Dim AllCells As Range, Cell As Range
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
' based on John Walkenbachs
' http://j-walk.com/ss/excel/tips/tip47.htm
' The items are in A1:A105
' Set AllCells = Range("A1:A105")
Set AllCells = rng
' 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
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell

' Resume normal error handling
On Error GoTo 0

' 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.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
' Next Item

' Show the UserForm

End Sub

----------
in the Frm1 module:

Private Sub CommandButton1_Click()
Tester3
End Sub

Private Sub UserForm_Initialize()
lb1.RowSource = ""
lb1.List = Worksheets("Sheet1").Range("B3:C24").Value
End Sub

--
Regards,
Tom Ogilvy

Stuart <> wrote in message
news:...
> Say frm1.lb1.Column(1) and Column(2) are populated
> from a range in a worksheet.
> Say a Collection has been built of unique and sorted
> values.
>
> Can I compare the values in the Collection with the
> values in Column(1) of the listbox such that:
>
> a) if the the value exists in the lb, then ok.
> b) if it doesn't, then add it to the lb.
> c) if there's a value in the lb that's not in the Collection,
> then remove it (and the lb.Column(2) value from the lb.
>
>
> Regards.
>
>
> ---
> Outgoing mail is certified Virus Free.
> Checked by AVG anti-virus system (http://www.grisoft.com).
> Version: 6.0.518 / Virus Database: 316 - Release Date: 11/09/2003
>
>

Tom Ogilvy, Sep 19, 2003

3. ### StuartGuest

Many thanks indeed.
It was mainly the use of arrays and Match
that was missing from my attempts.

Regards.

"Tom Ogilvy" <> wrote in message
news:...
> Put this is an empty workbook with a form named Frm1 having a listbox

named
> lb1 and a commandbutton named commandbutton1.
>
> On sheet1, put in a list of sorted values in B3:B24 and corresponding

names
> in C3:C24. In D324 put in sorted or unsorted entries similar to those

in
> B3:B24 (some added, some missing).
>
> Execute AA_showform and then press Commandbutton1 to adjust the list.
>
>
> In a general module:
> Option Explicit
>
> Sub AA_showform()
> frm1.Show
> End Sub
>
>
> Sub Tester3()
> Dim NoDupes As New Collection
> Dim rng As Range
> Dim i As Long
> Dim vVal As Variant
> Dim itm As Variant
> Dim res As Variant
> Dim varr2 As Variant, cnt As Long
> Dim varr As Variant, varr1 As Variant
>
> ' set up a collection
> Set rng = Worksheets("sheet1").Range("D324")
> RemoveDuplicates rng, NoDupes
> ' End Setup a collection
>
> With frm1.lb1
> cnt = .ListCount
> For i = .ListCount - 1 To 0 Step -1
> vVal = Empty
> On Error Resume Next
> vVal = NoDupes(.List(i, 0))
> ' Debug.Print i, vVal
> On Error GoTo 0
> If IsEmpty(vVal) Then
> .RemoveItem i
> cnt = cnt - 1
> End If
> Next
> varr = .List
> ReDim varr1(1 To cnt, 1 To 1)
> For i = 1 To cnt
> varr1(i, 1) = .List(i - 1, 0)
> Next
> ReDim varr2(1 To 2, 1 To 1)
> For Each itm In NoDupes
> res = Application.Match(itm, varr1, 1)
> If IsError(res) Then
> varr2(1, UBound(varr2, 2)) = itm
> varr2(2, UBound(varr2, 2)) = -1
> ReDim Preserve varr2(1 To 2, 1 To _
> UBound(varr2, 2) + 1)
> Else
> If itm <> varr1(res, 1) Then
> varr2(1, UBound(varr2, 2)) = itm
> varr2(2, UBound(varr2, 2)) = res
> ReDim Preserve varr2(1 To 2, 1 To _
> UBound(varr2, 2) + 1)
> End If
> End If
>
> Next
> For i = UBound(varr2, 2) - 1 To 1 Step -1
> If varr2(2, i) = -1 Then
> Else
> .AddItem varr2(1, i), varr2(2, i)
> End If
> Next
> End With
> End Sub
>
> Sub RemoveDuplicates(rng As Range, NoDupes As Collection)
> Dim AllCells As Range, Cell As Range
> Dim i As Integer, j As Integer
> Dim Swap1, Swap2, Item
> ' based on John Walkenbachs
> ' http://j-walk.com/ss/excel/tips/tip47.htm
> ' The items are in A1:A105
> ' Set AllCells = Range("A1:A105")
> Set AllCells = rng
> ' 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
> ' Note: the 2nd argument (key) for the Add method must be a string
> Next Cell
>
> ' Resume normal error handling
> On Error GoTo 0
>
> ' 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.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
> ' Next Item
>
> ' Show the UserForm
>
> End Sub
>
>
> ----------
> in the Frm1 module:
>
> Private Sub CommandButton1_Click()
> Tester3
> End Sub
>
> Private Sub UserForm_Initialize()
> lb1.RowSource = ""
> lb1.List = Worksheets("Sheet1").Range("B3:C24").Value
> End Sub
>
>
> --
> Regards,
> Tom Ogilvy
>
>
> Stuart <> wrote in message
> news:...
> > Say frm1.lb1.Column(1) and Column(2) are populated
> > from a range in a worksheet.
> > Say a Collection has been built of unique and sorted
> > values.
> >
> > Can I compare the values in the Collection with the
> > values in Column(1) of the listbox such that:
> >
> > a) if the the value exists in the lb, then ok.
> > b) if it doesn't, then add it to the lb.
> > c) if there's a value in the lb that's not in the Collection,
> > then remove it (and the lb.Column(2) value from the lb.
> >
> > Is this possible, please?
> >
> > Regards.
> >
> >
> > ---
> > Outgoing mail is certified Virus Free.
> > Checked by AVG anti-virus system (http://www.grisoft.com).
> > Version: 6.0.518 / Virus Database: 316 - Release Date: 11/09/2003
> >
> >

>
>

---
Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.518 / Virus Database: 316 - Release Date: 11/09/2003

Stuart, Sep 20, 2003