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

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 D3:D24 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("D3:D24")
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, befo=j
NoDupes.Add Swap2, befo=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


--
Regards,
Tom Ogilvy


Stuart wrote in message
...
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

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

Regards.

"Tom Ogilvy" wrote in message
...
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 D3:D24 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("D3:D24")
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, befo=j
NoDupes.Add Swap2, befo=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


--
Regards,
Tom Ogilvy


Stuart wrote in message
...
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