Excel - All unique words in a range

Question

Perhaps I'm trying to do too much, but I have a column filled with text. Each cell has an arbitrary number of words, so for example:

     |         A          |
=====|====================|
  1  | apple pear yes cat |
  2  | apple cat dog      |
  3  | pear orange        |

What I need to do is create a column which is a list of all unique words in that range. So for the above example, the result should be:

     |         A          |   B    |
=====|====================|========|
  1  | apple pear yes cat | apple  |
  2  | apple cat dog      | pear   |
  3  | pear orange        | yes    |
  4  |                    | cat    |
  5  |                    | dog    |
  6  |                    | orange |

In no particular order. Is there any way to do this?

Answer 1

This option uses 1 loop instead of 3, I like to use a dictionary instead or Collection.

Sub Sample()
Dim varValues As Variant
Dim strAllValues As String
Dim i As Long
Dim d As Object

'Create empty Dictionary
Set d = CreateObject("Scripting.Dictionary")

'Create String With all possible Values
strAllValues = Join(Application.Transpose(Range("A1", Range("A" & Rows.Count).End(xlUp))), " ")

'Split All Values by space into array
varValues = Split(strAllValues, " ")

'Fill dictionary with all values (this filters out duplicates)
For i = LBound(varValues) To UBound(varValues)
    d(varValues(i)) = 1
Next i

'Write All The values back to your worksheet
Range("B1:B" & d.Count) = Application.Transpose(d.Keys)
End Sub

Answer 2

Give this small macro a try:

Sub dural()
    Dim N As Long, U As Long, L As Long
    N = Cells(Rows.Count, "A").End(xlUp).Row
    Dim st As String
    For I = 1 To N
        st = st & " " & Cells(I, 1)
    Next I
    st = Application.WorksheetFunction.Trim(st)
    ary = Split(st, " ")
    U = UBound(ary)
    L = LBound(ary)
    Dim c As Collection
    Set c = New Collection
    On Error Resume Next
    For I = L To U
        c.Add ary(I), CStr(ary(I))
    Next I
    For I = 1 To c.Count
        Cells(I, 2).Value = c.Item(I)
    Next I
End Sub