List of values / unique problem
 

Hi,

This macro I use to create a list of unique values in a certain range. But,
values that look like each other, are not shown in my list. For example:
"red apple" and "apple" as values are seen as one, so apple will not be in
the list. How should I change it, so that every unique value is in my list?

Thanks, Gert-Jan

Dim rngData As Range
Dim strThisItem As String
Dim strUnqItms As String
Dim strTempAry() As String
Dim itm As Variant
For Each rngData In Worksheets("database").Range("B1:B100")
If rngData = "" Then Exit For
strThisItem = rngData
If InStr(strUnqItms, strThisItem) = 0 Then
strUnqItms = strUnqItms & "," & strThisItem
End If
Next rngData
strTempAry = Split(strUnqItms, ",")
Set rngData = Worksheets("sheets2").Range("J1")
For Each itm In strTempAry
If itm < "" Then
rngData = itm
Set rngData = rngData.Offset(1, 0)
End If
Next itm
End If

List of values / unique problem
 

I found a good solution:

Sub FilterUniqueNumbers()
Dim rngYourrange As Range
Dim rngCell As Range
Dim colUniqueNumbers As New Collection
Dim i As Integer
Set rngYourrange = Worksheets("database").Range("B1:B30")
On Error Resume Next
For Each rngCell In rngYourrange
colUniqueNumbers.Add rngCell.Value, CStr(rngCell.Value)
Next rngCell
For i = 1 To colUniqueNumbers.Count
Worksheets("sheet1").Cells(i, 2).Value = colUniqueNumbers(i)
Next i
End Sub


"Gert-Jan" schreef in bericht
...
Hi,

This macro I use to create a list of unique values in a certain range.
But, values that look like each other, are not shown in my list. For
example: "red apple" and "apple" as values are seen as one, so apple will
not be in the list. How should I change it, so that every unique value is
in my list?

Thanks, Gert-Jan

Dim rngData As Range
Dim strThisItem As String
Dim strUnqItms As String
Dim strTempAry() As String
Dim itm As Variant
For Each rngData In Worksheets("database").Range("B1:B100")
If rngData = "" Then Exit For
strThisItem = rngData
If InStr(strUnqItms, strThisItem) = 0 Then
strUnqItms = strUnqItms & "," & strThisItem
End If
Next rngData
strTempAry = Split(strUnqItms, ",")
Set rngData = Worksheets("sheets2").Range("J1")
For Each itm In strTempAry
If itm < "" Then
rngData = itm
Set rngData = rngData.Offset(1, 0)
End If
Next itm
End If