Sulprobil
Search…
Lfreq
"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.
Please read my Disclaimer.
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
A bit faster is Lfreq2 which is working only on ranges:
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)
Else
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
Range("B:B").ClearContents
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 = _
Application.WorksheetFunction.Transpose(obj.Keys)
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.
'Example:
'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
Err.Clear
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
Else
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
Copy link