Is there a faster/better way to accomplish scan of a range for unique text values/save those unique values to range, sort alphabetically?

[johnnyL]

Book1.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1
2
3			Red	14	6		Green	8	3		Blue	1	3		Brown	4	10		Black	2	5
4			Blue	2	1		Purple	2	7		Red	4	2						Green	6	1
5			Green	5	2		Orange	6	1										Orange	4	7
6							Red	0	5										Purple	8	3
7							Yellow	4	9
8							Black	12	13
Sheet1

Back to this file ...

I want to capture unique text values from a range, sort that range, into the A column, and possibly even count the occurrences of each unique text value found into the corresponding B column.

The following is the code that I have came up with thus far ...

Sub Find_PrintUniqueNonNumericTextFoundInSelectedRangeToRangeAndSortFoundTextAlphabetically()    ' Works
    Dim DataFoundInCell As Range, r As Range, x0
'
'   \/ Variables to set \/
    SortRange1stCellAddress = "C3"
    SortRangeLastCellAddress = "U8"
'
    With CreateObject("scripting.dictionary")
        For Each DataFoundInCell In ActiveSheet.Range(SortRange1stCellAddress & ":" & SortRangeLastCellAddress).SpecialCells(2)
            If Not IsNumeric(DataFoundInCell) Then x0 = .Item(DataFoundInCell.Value)      '
        Next
'
        Set r = Cells(1, "A").Resize(.Count, 1)                 '
'
        r.Value = Application.Transpose(.Keys)                  '
    End With
'
'   Sort Column A, that now contains the unique text values, alphabetically
'   \/ Variables to set \/
    SortRange1stCellAddress = "A1"
    SheetName = "Sheet1"
'
    SortRangeLastCellAddress = Range(SortRange1stCellAddress).End(xlDown).Address(0, 0)     '
'
    ActiveWorkbook.Worksheets(SheetName).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(SheetName).Sort.SortFields.Add Key:=Range(SortRange1stCellAddress), Order:=xlAscending    ' Predominant sort starting address
'
    With ActiveWorkbook.Worksheets(SheetName).Sort
        .SetRange Range(SortRange1stCellAddress & ":" & SortRangeLastCellAddress)
        .Header = xlNo
        .Apply
    End With
End Sub

 

[Fluff]

How about

Sub JonnyL()
   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("C3:U8").SpecialCells(xlConstants, xlTextValues)
         .Item(Cl.Value) = .Item(Cl.Value) + 1
      Next Cl
      Range("A1").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
      Range("A1").Resize(.Count, 2).Sort Range("A1"), xlAscending, , , , , , xlNo
   End With
End Sub

 

[Marc L]

Hi,​

​

can be also fast achieved just with Excel / VBA basics - different ways - without any Dictionary …​

​

 

[johnnyL]

@Fluff Nice!!! Less than half the code I used and you threw in the bonus.
Thank you so much @Fluff !!!

 

[Fluff]

Glad to help & thanks for the feedback.

 

[johnnyL]

Another question please, I try to digest what lines of code do so I can learn more. What does the following @Fluff line of code do:

.Item(Cl.Value) = .Item(Cl.Value) + 1

 

[Fluff]

It adds the cell value to the dictionary as the key if it does not already exist & increases the item for that key by one.

 

[johnnyL]

Eureka! Thank you @Fluff ! I was wondering how you did the counter. That explains it.

 

[Fluff]

You're welcome & thanks for the feedback.

 

[johnnyL]

It adds the cell value to the dictionary as the key if it does not already exist & increases the item for that key by one.

From my googling, I think you can only store 1 set of unique keys and 1 set of corresponding items. What I was wanting to do now is get the unique keys and a running total that would be added from a column 2 to the right of the key found. For example in my OP above, the key would be from the 1st column (color column) and the total to add would be the 3rd column corresponding values.

So:

Color Total Qty
Black     18
Red       13
Brown     10
Purple    10
Yellow     9
Orange     8
Green      6
Blue       4

If I have not googled enough to find a way to have the counter included also, like in the original solution then the following would be my goal:

Color    Times Ordered    Total Qty
Green             3            6
Red               3           13
Black             2           18
Blue              2            4
Orange            2            8
Purple            2           10
Brown             1           10
Yellow            1            9

A column could be inserted, if need be, to have columns A - C for the result range.