Sorted range into collection
Hi Matt, your suggestion has been very helpful to me, thank you very much.
I changed your sub into a function (its what I needed from the beginning);
Im posting it below, hoping it could be useful to anyone.
Thanks a lot again.
Maurizio
Public Function getDistincValuesFromRange(strSelectedSheet As String,
strSelectedColumn As String) As Collection
Dim rngData As Range
Dim rngCell As Range
Dim colNoRepeats As New Collection
Dim lngJ As Long
Dim lngK As Long
Dim varCurr As Variant
Dim varNext As Variant
Dim varItem As Variant
Dim strStartCell As String
Dim strLastCellInColumn As String
'if you want all the values
'strStartCell = strSelectedColumn & "1"
'if you want all the values except the header
strStartCell = strSelectedColumn & "2"
strLastCellInColumn = strSelectedColumn & "65536"
Set rngData =
ActiveWorkbook.Sheets(strSelectedSheet).Range(strS tartCell,
Range(strLastCellInColumn).End(xlUp))
On Error Resume Next
For Each rngCell In rngData.Cells
colNoRepeats.Add Item:=rngCell.Value, Key:=CStr(rngCell.Value)
Next
On Error GoTo 0
For lngJ = 1 To colNoRepeats.Count - 1
For lngK = lngJ + 1 To colNoRepeats.Count
varCurr = colNoRepeats(lngJ)
varNext = colNoRepeats(lngK)
If varCurr = varNext Then
colNoRepeats.Add Item:=varCurr, Befo=lngK
colNoRepeats.Add Item:=varNext, Befo=lngJ
colNoRepeats.Remove lngJ + 1
colNoRepeats.Remove lngK + 1
End If
Next
Next
Set getDistincValuesFromRange = colNoRepeats
End Function
See below. This sub will work on the specified column data (which for
the purposes of the sub below is the data in column A). My first
learned this from J-Walk's website.
Best,
Matt Herbert
Sub CollectionOneColumn()
Dim rngData As Range
Dim rngCell As Range
Dim colNoRepeats As New Collection
Dim lngJ As Long
Dim lngK As Long
Dim varCurr As Variant
Dim varNext As Variant
Dim varItem As Variant
Set rngData = Range("a1", Cells(Columns("A").Cells.Count, 1).End
(xlUp))
On Error Resume Next
For Each rngCell In rngData.Cells
colNoRepeats.Add Item:=rngCell.Value, Key:=CStr(rngCell.Value)
Next
On Error GoTo 0
For lngJ = 1 To colNoRepeats.Count - 1
For lngK = lngJ + 1 To colNoRepeats.Count
varCurr = colNoRepeats(lngJ)
varNext = colNoRepeats(lngK)
If varCurr = varNext Then
colNoRepeats.Add Item:=varCurr, Befo=lngK
colNoRepeats.Add Item:=varNext, Befo=lngJ
colNoRepeats.Remove lngJ + 1
colNoRepeats.Remove lngK + 1
End If
Next
Next
For Each varItem In colNoRepeats
Debug.Print varItem
Next
End Sub
|