Hi,
I have found the following formula which I'm trying to use to try to sort a
table of four columns into a list of unique values - but I can't get it to
work!
My data is in cols Z3 to AE100, its a mix of text and numbers. It looks
something like
A3 BB A4 DD
BB A4 CC EE
A3 A4 EE A1
I would like a list outputted that reads (in any order whatsoever)
A3
BB
A4
DD
EE
A1
CC
Is this possible?
Thanks in advance
This Sub will output your data, sorted either by frequency or alphabetically,
into a desired range.
See the notes within the macro.
As written, both the source and results are "hard-coded" but can be changed
easily enough. Also, the results can be sorted either alphabetically or
numerically -- again, see the notes within the macro for instructions.
To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro
by name, and <RUN>.
========================================
Option Explicit
Option Compare Text
Sub Uniques()
Dim rDest As Range
Dim rg As Range
'There are many ways to define the
' range to process.
Set rg = Range("Z3:AE100")
'There are also many ways to define
' the output range
Set rDest = Range("A1")
Dim cWordList As Collection
Dim str As String
Dim sRes() As Variant
Dim i As Long, J As Long
Dim c As Range
'get list of unique words
Set cWordList = New Collection
On Error Resume Next
For Each c In rg
cWordList.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
ReDim sRes(0 To 1, 1 To cWordList.Count)
For i = 1 To cWordList.Count
sRes(0, i) = cWordList(i)
Next i
'get word count for each word
For i = 1 To UBound(sRes, 2)
sRes(1, i) = Application.WorksheetFunction.CountIf(rg, sRes(0, i))
Next i
'Reverse sorting order if you want the words alphabetically
'without respect to the counts
'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True
'then sort by Count highest to lowest
BubbleSortX sRes, 1, False
For i = LBound(sRes, 2) To UBound(sRes, 2)
rDest(i, 1).Value = sRes(0, i)
rDest(i, 2).Value = sRes(1, i)
Next i
End Sub
'--------------------------------------------------------------
Private Sub BubbleSortX(TempArray As Variant, d As Long, _
bSortDirection As Boolean)
'bSortDirection = True means sort ascending
'bSortDirection = False means sort descending
Dim Temp1 As Variant, Temp2
Dim i As Long
Dim NoExchanges As Boolean
Dim Exchange As Boolean
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For i = 1 To UBound(TempArray, 2) - 1
' If the element is greater/less than the element
' following it, exchange the two elements.
Exchange = TempArray(d, i) < TempArray(d, i + 1)
If bSortDirection = True Then Exchange = _
TempArray(d, i) > TempArray(d, i + 1)
If Exchange Then
NoExchanges = False
Temp1 = TempArray(0, i)
Temp2 = TempArray(1, i)
TempArray(0, i) = TempArray(0, i + 1)
TempArray(1, i) = TempArray(1, i + 1)
TempArray(0, i + 1) = Temp1
TempArray(1, i + 1) = Temp2
End If
Next i
Loop While Not (NoExchanges)
End Sub
========================================
--ron
