# Compare Listbox values with Collection values

Stuart
Guest
Posts: n/a

 19th Sep 2003
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
Guest
Posts: n/a

 19th Sep 2003
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 <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> 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
Guest
Posts: n/a

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

Regards.

"Tom Ogilvy" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> 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 <(E-Mail Removed)> wrote in message
> news:(E-Mail Removed)...
> > 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

 Thread Tools Rate This Thread Rate This Thread: 5 : Excellent 4 : Good 3 : Average 2 : Bad 1 : Terrible

 Posting Rules You may not post new threads You may not post replies You may not post attachments You may not edit your posts BB code is On Smilies are On [IMG] code is On HTML code is OffTrackbacks are On Pingbacks are On Refbacks are Off Forum Rules

 Similar Threads Thread Thread Starter Forum Replies Last Post Stuart McCall Microsoft Access Form Coding 3 18th Feb 2010 10:49 PM Øyvind Isaksen Microsoft ASP .NET 1 18th May 2007 10:24 AM Øyvind Isaksen Microsoft Dot NET 1 18th May 2007 10:24 AM Kevin Quigley Microsoft Dot NET 2 2nd Jun 2004 11:34 AM ARB Microsoft Excel Programming 0 22nd Oct 2003 12:46 AM

Features