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
   Dim Tmp As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("D3:V8").SpecialCells(xlConstants, xlTextValues)
         If Not .Exists(Cl.Value) Then
            .Item(Cl.Value) = Array(Cl.Offset(, 1).Value, 1)
         Else
            Tmp = .Item(Cl.Value)
            Tmp(0) = Tmp(0) + Cl.Offset(, 1).Value
            Tmp(1) = Tmp(1) + 1
            .Item(Cl.Value) = Tmp
         End If
      Next Cl
      Range("A2").Resize(.Count, 1).Value = Application.Transpose(.Keys)
      Range("B2").Resize(.Count, 2).Value = Application.Index(.Items, 0)
      Range("A2").Resize(.Count, 3).Sort Range("A1"), xlAscending, , , , , , xlYes
   End With
End Sub

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

 

[johnnyL]

Again, Thank you so much @Fluff !!!

I encountered one tiny error in your code.

Range("A2").Resize(.Count, 3).Sort Range("A1"), xlAscending, , , , , , xlYes

The 'A2' should be 'A1' OR the xlYes should be xlNo. I chose the 'A1' fix.

Now I just have to look at the code and try to digest the ineer workings of it. Thanks again!

 

[Fluff]

You're welcome & thanks for the feedback.

 

[johnnyL]

How would I do it so the B & C column results were switched? In other words, the current B column results into the C column and the current C column results into the B column.

 

[Fluff]

Just swap the values round in the array & the Tmp array

 

[johnnyL]

Just swap the values round in the array & the Tmp array

I already tried:

            Tmp(0) = Tmp(0) + 1
            Tmp(1) = Tmp(1) + Cl.Offset(, 2).Value

Not sure what else needs to be changed, but that change alone didn't work.

 

[Fluff]

You also need to swap then round on this line

Array(Cl.Offset(, 1).Value, 1)

 

[johnnyL]

I see, said the blind man to his deaf wife as he picked up the hammer and saw.

Thanks again again @Fluff !!!

 

[Fluff]

My pleasure.

 

[johnnyL]

Another follow up question please.

In the line:

Array(Cl.Offset(, 1).Value, 1)

Why/How does the '1' at the end of the line equate to the counter? Why doesn't it use the same format as:

Cl.Offset(, ?).Value

What makes the '1' so magical, and the Cl.Offset method not work for the counter?