Unique string values in range

Question

I have some spreadsheets where there are large number of cells that have essentially been used for free text.

There is a finite set of values for this free text and most, if not all repeat.

eg.

   A        B       C       D
1  Monkey   Gorilla Cat     Dog
2  Dog      Cat     Gorilla Gorilla
3  Dog      Dog     Dog     Cat

There are probably 50 or so different cell values spread over multiple sheets and hundreds of rows and columns.

I need to analyse this data and count occurancies, which is not a problem other than getting a list of unique values to start with and this has been driving me up the wall.

What is the best way to produce this list.

So from the above we would have

Monkey
Dog
Cat
Gorilla

In order of preferred solutions, as this will need to be done monthly.

1. Dynamic formula based
2. VB Script
3. Other ( Advanced filtering or other manual steps )

Answer 1

Based on some starting code found here, this USER DEFINED FUNCTION will collect all the values from all the cells on all OTHER sheets than the one you use this function on. So be clear, insert a blank sheet into your workbook and use this function on that sheet only.

=UNIQUE(ROW(A1))

Put that formula in any cell, then copy down until no more values appear.

In that same workbook, put this UDF code into a blank module (Insert > Module):

    Option Explicit

    Function UNIQUE(ItemNo As Long) As Variant
    Dim cl As Range, cUnique As New Collection, cValue As Variant
    Dim ws As Worksheet, Inputrange As Range
    Application.Volatile

    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> Application.Caller.Parent.Name Then
            For Each cl In ws.UsedRange
                If cl.Formula <> "" Then cUnique.Add cl.Value, CStr(cl.Value)
            Next cl
        End If
    Next ws
    On Error GoTo 0

    UNIQUE = ""
    If ItemNo = 0 Then
        UNIQUE = cUnique.Count
    ElseIf ItemNo <= cUnique.Count Then
        UNIQUE = cUnique(ItemNo)
    End If

    End Function

Answer 2

Assuming the data is small enough to fit in one column on a worksheet, I'd copy all columns into one column and create a simple pivot table to count each value for me.

To run it frequently, I'd create a VBA Macro, not a VB Script. The below procedure will do the whole thing automatically in Excel 2010. (Some of the pivot table code might be different in earlier versions of Excel.)

Sub CreateSummary()
' This macro assumes there is nothing else below the data being summarized
' and that there are no empty cells in any of the columns of data.
   Const FIELDNAME As String = "FreeText"
   Dim v As Variant
   Dim sht As Worksheet, rTop As Range, r As Range
   Dim pc As PivotCache, pt As PivotTable

   Set v = Application.InputBox("Select first cell of table to be summarized." _
                               , "Create Summary", Type:=8)
   If TypeName(v) = "Range" Then
      Set rTop = v
   Else
      Exit Sub
   End If
   Set sht = rTop.Parent

   ' create new summary worksheet
   sht.Copy
   ActiveSheet.Name = sht.Name & " Summary"
   Set sht = ActiveSheet
   Set rTop = sht.Range(rTop.Address)

   ' add header
   rTop.Rows.EntireRow.Insert
   With rTop.Offset(-1)
      .Value = FIELDNAME
      .Font.Bold = True
      .BorderAround XlLineStyle.xlContinuous
   End With

   ' Grab data from other columns and move it to first column
   Application.ScreenUpdating = False
   Application.StatusBar = "Converting table to one column ..."
   Set r = rTop.Offset(0, 1)
   Do While r.Value <> ""
      sht.Range(r, r.SpecialCells(xlCellTypeLastCell)).Cut
      rTop.End(xlDown).Offset(1).Select
      sht.Paste
      Set r = r.Offset(0, 1)
      Application.StatusBar = Application.StatusBar & "."
      DoEvents
   Loop
   rTop.Select
   Application.ScreenUpdating = True

   ' create PivotTable
   Application.ScreenUpdating = False
   Application.StatusBar = "Creating pivot table..."
   Set r = Range(rTop.Offset(-1), rTop.End(xlDown))
   With ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=r.Address)
      With .CreatePivotTable(TableDestination:=rTop.Offset(-1, 2))
         .AddDataField .PivotFields(FIELDNAME), "Count", xlCount
         .AddFields FIELDNAME, , , True
      End With
   End With
   Application.ScreenUpdating = True
   Application.StatusBar = False

   Set r = Nothing
   Set rTop = Nothing
   Set sht = Nothing

   MsgBox "Done creating summary."
End Sub