Sub GetUniquesMultipleColumns()
'prompts for you to click the top item of your list and click OK, then repeat for each list
'when no more lists to add, click cancel
'then click on the cell where your output range should begin and click OK
Dim Rng As Range, Dn As Range, objDict As Object, varVal As Variant
Set objDict = CreateObject("scripting.dictionary")
With objDict
.comparemode = vbTextCompare
Do
On Error Resume Next
Set Rng = Nothing
Set Rng = application.InputBox("Click the top-most item of the next column to compare.", "Select Input Range", Type:=8)
If Rng Is Nothing Then Exit Do
Set Rng = Rng.Parent.Range(Rng, Rng.Parent.Cells(Rows.Count, Rng.Column).End(xlUp))
For Each Dn In Rng
'put an apostrophe in front of the value if it appears to be number stored as text - unless it's a boolean
If VarType(varVal) <> vbBoolean Then
varVal = Dn.Value
varVal = CDbl(Dn.Value)
varVal = IIf(Len(Dn.Value) <> Len(varVal), "'" & Dn.Value, Dn.Value)
End If
'add the value to the dictionary
If Not .exists(Dn.Value) Then .Add Key:=varVal, Item:=Dn.Next.Value
Next
On Error GoTo 0
If MsgBox("Do you want to add to your data set?", vbQuestion + vbYesNo + vbDefaultButton2, "More Data?") = vbNo Then Exit Do
Loop
Set Rng = Nothing
On Error Resume Next
If .Count = 0 Then Exit Sub 'objDict.Count = 0 would mean no values are in the dictionary
Set Rng = application.InputBox("Click the cell where you want the unique list to begin.", "Select Output Range", Type:=8).Resize(.Count)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub
Rng.Value = application.Transpose(Array(.keys))
End With
'show the range where the unique list was just placed
Rng.Parent.Parent.Activate
Rng.Parent.Activate
If MsgBox("Do you want to sort the unique list?", vbYesNo, "Sort List?") = vbYes Then Rng.Sort Key1:=Rng(1), Order1:=xlAscending, Header:=xlNo
End Sub
