Sorted range into collection

[mm_it_it]

Hi everyone,
I'm working with excel 2003 and I'm developing a custom interface to
automatize some operations.
I'm using the MS office VB editor. I can't use .net framework.
I need to:
- take the values contained in an excel column
- sort values alphabetically
- remove duplicate values
- put the values in a collection.
I need to do everything "on the code side", cell values on the sheet cannot
be modified.
The requisite of the collection is not mandatory, any similar object would
be useful.
I did many test but none of them works.
Thanks in advance to everybody

 

[ryguy7272]

Sub Macro1()


Dim lLastRow As Long
Dim lLastCol As Long
Dim i As Long
Dim j As Long
Dim k As Long

Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select


lLastRow = ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Columns.Count - 1
For i = 0 To lLastRow - 1
For j = lLastRow To i + 1 Step -1
For k = 0 To lLastCol
If ActiveSheet.Range("A1").Offset(i, k).Value <>
ActiveSheet.Range("A1").Offset(j, k).Value Then
Exit For
End If
Next k
If k > lLastCol Then
ActiveSheet.Range("A1").Offset(j, 0).EntireRow.Delete
End If
Next j
Next i

End Sub

Before you run this code, make a backup of your data in case it does
something you don't expect!!

HTH,
Ryan---

 

[mm_it_it]

Maybe I wrote something that is almost right:

Public Function getDistincValuesFromRange(rangeValue As String) As Collection

Dim tmpCollection As Collection
Set tmpCollection = New Collection

Dim tmpRange As Range
Dim tmpCell As Variant

'Set tmpRange = ActiveWorkbook.Sheets("DataSheet").Range("A:A")
Set tmpRange = ActiveWorkbook.Sheets("DataSheet").Range(rangeValue)

For Each tmpCell In tmpRange
On Error Resume Next
tmpCollection.Add tmpCell.Value, tmpCell.Value
Next

tmpCollection.Sort Key1:="Key"

End Function

Unfortunately I'm still having problems with the last instruction, it
doesn't sort the collection, but it neither raise any error ...
Is it the way I use the sort method?
Thanks again

 

[meh2030]

Sub Macro1()

Dim lLastRow As Long
Dim lLastCol As Long
Dim i As Long
Dim j As Long
Dim k As Long

    Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("A1").Select

lLastRow = ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Columns.Count - 1
  For i = 0 To lLastRow - 1
    For j = lLastRow To i + 1 Step -1
      For k = 0 To lLastCol
        If ActiveSheet.Range("A1").Offset(i, k).Value <>
ActiveSheet.Range("A1").Offset(j, k).Value Then
          Exit For
        End If
      Next k
      If k > lLastCol Then
        ActiveSheet.Range("A1").Offset(j, 0).EntireRow.Delete
      End If
    Next j
  Next i

End Sub

Before you run this code, make a backup of your data in case it does
something you don't expect!!

HTH,
Ryan---
--
Ryan---
If this information was helpful, please indicate this by clicking ''Yes''..





- Show quoted text -

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, Before:=lngK
colNoRepeats.Add Item:=varNext, Before:=lngJ
colNoRepeats.Remove lngJ + 1
colNoRepeats.Remove lngK + 1
End If
Next
Next

For Each varItem In colNoRepeats
Debug.Print varItem
Next

End Sub

 

[mm_it_it]

Hi Matt, your suggestion has been very helpful to me, thank you very much.
I changed your sub into a function (it’s what I needed from the beginning);
I’m 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(strStartCell,
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, Before:=lngK
colNoRepeats.Add Item:=varNext, Before:=lngJ
colNoRepeats.Remove lngJ + 1
colNoRepeats.Remove lngK + 1
End If

Next

Next

Set getDistincValuesFromRange = colNoRepeats

End Function