Stick with the collection. To get the Uniques (my oversight), you need to
add a key value:
Change
EnquiryList.Add Cell.Value
to
EnquiryList.Add Cell.Value, cstr(cell.Value)
I also missed the correction which solved your immediate question:
Set DataRange = Range("H2", "J" & LastRow)
does not have a period (full stop) in front of range and thus refers to the
active sheet, so change it to
Set DataRange = .Range("H2", "J" & LastRow)
so that is why you were not getting the values from the second sheet.
Here is a revision that uses John's sort to produce a sorted list of
uniques:
Sub SortContractorsSuppliers()
Dim ws As Worksheet, LastRow As Long
Dim DataRange As Range, Cell As Range
Dim EnquiryList As New Collection
For Each ws In ActiveWorkbook.Worksheets
With ws
.Unprotect
LastRow = Application.Max(.Range("H65536") _
.End(xlUp).Row, .Range("I65536").End(xlUp).Row, _
.Range("J65536").End(xlUp).Row)
Set DataRange = .Range("H2", "J" & LastRow)
On Error Resume Next
For Each Cell In DataRange
If Not IsEmpty(Cell) Then
EnquiryList.Add Cell.Value, CStr(Cell.Value)
End If
Next Cell
On Error GoTo 0
End With
Next
For i = 1 To EnquiryList.Count - 1
For j = i + 1 To EnquiryList.Count
If EnquiryList(i) EnquiryList(j) Then
Swap1 = EnquiryList(i)
Swap2 = EnquiryList(j)
EnquiryList.Add Swap1, befo=j
EnquiryList.Add Swap2, befo=i
EnquiryList.Remove i + 1
EnquiryList.Remove j + 1
End If
Next j
Next i
For Each itm In EnquiryList
Debug.Print itm
Next
End Sub
You can use arrays if you want, but the above works fine.
--
Regards,
Tom Ogilvy
Stuart wrote in message
...
Many thanks to you both.
I was trying to use a Collection because I thought I had
read somewhere about it automatically excluding any
duplicates.........sure enough that link to J. W.'s site
confirms this (hence the use of OERN to suppress any
messages).
I imported Tom's code:
However, when I ran the code on my test sheets, it did
not exclude duplicates. Is it worth pursuing (out of
interest) the Collection idea, or perhaps follow the array
route?
Regards.
"Tom Ogilvy" wrote in message
...
I believe it does work (at least it did for me), but you can't see the
result with
msgbox EnquiryList
Sub SortContractorsSuppliers()
Dim ws As Worksheet, LastRow As Long
Dim DataRange As Range, Cell As Range
Dim EnquiryList As New Collection
For Each ws In ActiveWorkbook.Worksheets
With ws
.Unprotect
LastRow = Application.Max(.Range("H65536") _
.End(xlUp).Row, .Range("I65536").End(xlUp).Row, _
.Range("J65536").End(xlUp).Row)
Set DataRange = Range("H2", "J" & LastRow)
On Error Resume Next
For Each Cell In DataRange
If Not IsEmpty(Cell) Then
EnquiryList.Add Cell.Value
End If
Next Cell
On Error GoTo 0
End With
Next
sStr = ""
For Each itm In EnquiryList
sStr = sStr & itm & vbNewLine
Next
msgbox sStr
End Sub
See John Walkenbach's site for an example to follow including sorting
http://j-walk.com/ss/excel/tips/tip47.htm
--
Regards,
Tom Ogilvy
Stuart wrote in message
...
I'm looking to take unique values from a defined range
into a form. The values will be alphabetic characters.
Here is what I have so far:
Sub SortContractorsSuppliers()
Dim ws As Worksheet, LastRow As Long
Dim DataRange As Range, Cell As Range
Dim EnquiryList As New Collection
For Each ws In ActiveWorkbook.Worksheets
With ws
.Unprotect
LastRow = Application.Max(.Range("H65536") _
.End(xlUp).Row, .Range("I65536").End(xlUp).Row, _
.Range("J65536").End(xlUp).Row)
Set DataRange = Range("H2", "J" & LastRow)
On Error Resume Next
For Each Cell In DataRange
If Not IsEmpty(Cell) Then
EnquiryList.Add Cell.Value
End If
Next Cell
On Error GoTo 0
End With
Next
MsgBox EnquiryList
End Sub
Why is it that when the code loops into the 2nd sheet, any
unique values in that sheet's DataRange are not added to the
Collection, please?
Regards.
---
Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.512 / Virus Database: 309 - Release Date: 19/08/2003
---
Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (http://www.grisoft.com).
Version: 6.0.512 / Virus Database: 309 - Release Date: 19/08/2003