Compare Listbox values with Collection values

[Stuart]

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.

 

[Tom Ogilvy]

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
.AddItem varr2(1, i), 0
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
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

' 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

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

 

[Stuart]

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

Regards.