I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!



"Not everything that counts can be counted, and not everything that can be counted counts."
[Albert Einstein]

If you like to create a statistic about frequencies of strings or numbers, you can use pivot tables or perhaps one of my UDF's shown below. Lfreq uses associative arrays like PERL, List_Freq relies on a collection and offers a more complex functionality:


Please note that GSort has just been used here to beautify/sort the output.

Function Lfreq(v As Variant) As Variant
'Lfreq lists how often each value in v appears.
'Reverse("moc.liborplus.www") PB V0.5 07-Mar-2009
Dim obj As Object
Dim vR As Variant
Dim i As Long

Set obj = CreateObject("Scripting.Dictionary")
With Application.WorksheetFunction
vR = .Transpose(.Transpose(v))
On Error Resume Next
For i = LBound(vR, 1) To UBound(vR, 1)
    obj.Item(vR(i, 1)) = obj.Item(vR(i, 1)) + 1
Next i
Lfreq = .Transpose(Array(obj.keys, obj.items))
End With
End Function

Lfreq2 which works on ranges only is a bit faster:

Function Lfreq2(r As Range) As Variant
'Lfreq2 lists how often each value in r appears.
'Reverse("moc.liborplus.www") PB V0.1 25-Apr-2010
Dim obj As Object
Dim i As Long
Set obj = CreateObject("Scripting.Dictionary")
For i = 1 To r.Count
    obj.Item(r(i).Value) = obj.Item(r(i).Value) + 1
Next i
Lfreq2 = Application.WorksheetFunction.Transpose(Array(obj.keys, obj.items))
Set obj = Nothing
End Function

Function Lfreq3(r As Range) As Variant
'Lfreq3 returns a frequency statistic of the input.
'Example: Lfreq3({"a","a","b","b","b"}) will return {2,3}
'Reverse("moc.liborplus.www") PB V0.10 03-Sep-2010
Dim obj As Object
Dim i As Long
Set obj = CreateObject("Scripting.Dictionary")
For i = 1 To r.Count
    obj.Item(r(i).Value) = obj.Item(r(i).Value) + 1
Next i
With Application
If .Caller.Rows.Count > .Caller.Columns.Count Then
    Lfreq3 = .Transpose(obj.items)
    Lfreq3 = obj.items
End If
End With
Set obj = Nothing
End Function

A variant which only lists dupes:

Sub Ld()
'Ld lists dupes of column A in column B.
'Reverse("moc.liborplus.www") PB V0.1 10-Mar-2013
Dim obj As Object
Dim i As Long, v
Set obj = CreateObject("Scripting.Dictionary")
For Each v In Intersect(Range("A:A"), ActiveSheet.UsedRange)
    If Not IsEmpty(v) Then obj.Item(v.Value) = obj.Item(v.Value) + 1
Next v
For i = obj.Count - 1 To 0 Step -1
    If obj.Items()(i) < 2 Then obj.Remove obj.Keys()(i)
Next i
If obj.Count > 0 Then Range("B1:B" & obj.Count).FormulaArray = _
End Sub

Function List_Freq(rngSource As Range, _
    Optional lngLength As Long = 5) As Variant
'List_Freq counts strings of lngLength subsequent
'cells and returns a list of sorted strings and
'their frequencies.
'If A1:C2 are filled with the numbers
'0 1 0
'1 0 1
'then =List_Freq(A1:C2,2) array-entered in
'4 cells (2x2 array of cells, enter with CTRL +
'SHIFT + ENTER) will return
'01 2
'10 2
'the first column consisting of strings
Dim coll As New Collection
Dim lngFreq As Long, lngIndex As Long
Dim lngFound As Long
Dim i As Long, j As Long, k As Long
Dim sPattern As String

If rngSource.Columns.Count < lngLength Then
    List_Freq = CVErr(xlErrValue)
    Exit Function
End If

ReDim vA(1 To rngSource.Rows.Count * _
    (rngSource.Columns.Count - lngLength + 1), _
    1 To 2) As Variant

On Error Resume Next

'Count the frequencies
For j = 1 To rngSource.Rows.Count
    For i = 1 To rngSource.Columns.Count - _
            lngLength + 1
        sPattern = rngSource.Cells(j, i)
        For k = 1 To lngLength - 1
            sPattern = sPattern & _
                rngSource.Cells(j, i + k)
        Next k
        lngFound = coll("X" & sPattern)
        If Err.Number <> 0 Then
            lngIndex = lngIndex + 1
            coll.Add lngIndex, "X" & sPattern
            vA(lngIndex, 1) = sPattern
            vA(lngIndex, 2) = 1
            vA(lngFound, 1) = sPattern
            vA(lngFound, 2) = vA(lngFound, 2) + 1
        End If
    Next i
Next j

'Sort output
For i = 1 To lngIndex
    For j = i + 1 To lngIndex
        If vA(i, 1) > vA(j, 1) Then
            sPattern = vA(j, 1)
            vA(j, 1) = vA(i, 1)
            vA(i, 1) = sPattern
            lngFound = vA(j, 2)
            vA(j, 2) = vA(i, 2)
            vA(i, 2) = lngFound
        End If
    Next j
Next i

List_Freq = vA

End Function

Sulprobil   Get it done   Contact   Disclaimer   Download