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.
1
Function Lfreq(v As Variant) As Variant
2
'Lfreq lists how often each value in v appears.
3
'Reverse("moc.liborplus.www") PB V0.5 07-Mar-2009
4
Dim obj As Object
5
Dim vR As Variant
6
Dim i As Long
7
8
Set obj = CreateObject("Scripting.Dictionary")
9
With Application.WorksheetFunction
10
vR = .Transpose(.Transpose(v))
11
On Error Resume Next
12
For i = LBound(vR, 1) To UBound(vR, 1)
13
obj.Item(vR(i, 1)) = obj.Item(vR(i, 1)) + 1
14
Next i
15
Lfreq = .Transpose(Array(obj.keys, obj.items))
16
End With
17
End Function
Copied!
A bit faster is Lfreq2 which is working only on ranges:
1
Function Lfreq2(r As Range) As Variant
2
'Lfreq2 lists how often each value in r appears.
3
'Reverse("moc.liborplus.www") PB V0.1 25-Apr-2010
4
Dim obj As Object
5
Dim i As Long
6
Set obj = CreateObject("Scripting.Dictionary")
7
For i = 1 To r.Count
8
obj.Item(r(i).Value) = obj.Item(r(i).Value) + 1
9
Next i
10
Lfreq2 = Application.WorksheetFunction.Transpose(Array(obj.keys, obj.items))
11
Set obj = Nothing
12
End Function
Copied!
1
Function Lfreq3(r As Range) As Variant
2
'Lfreq3 returns a frequency statistic of the input.
3
'Example: Lfreq3({"a","a","b","b","b"}) will return {2,3}
4
'Reverse("moc.liborplus.www") PB V0.10 03-Sep-2010
5
Dim obj As Object
6
Dim i As Long
7
Set obj = CreateObject("Scripting.Dictionary")
8
For i = 1 To r.Count
9
obj.Item(r(i).Value) = obj.Item(r(i).Value) + 1
10
Next i
11
With Application
12
If .Caller.Rows.Count > .Caller.Columns.Count Then
13
Lfreq3 = .Transpose(obj.items)
14
Else
15
Lfreq3 = obj.items
16
End If
17
End With
18
Set obj = Nothing
19
End Function
Copied!
A variant which only lists dupes:
1
Sub Ld()
2
'Ld lists dupes of column A in column B.
3
'Reverse("moc.liborplus.www") PB V0.1 10-Mar-2013
4
Dim obj As Object
5
Dim i As Long, v
6
Range("B:B").ClearContents
7
Set obj = CreateObject("Scripting.Dictionary")
8
For Each v In Intersect(Range("A:A"), ActiveSheet.UsedRange)
9
If Not IsEmpty(v) Then obj.Item(v.Value) = obj.Item(v.Value) + 1
10
Next v
11
For i = obj.Count - 1 To 0 Step -1
12
If obj.Items()(i) < 2 Then obj.Remove obj.Keys()(i)
13
Next i
14
If obj.Count > 0 Then Range("B1:B" & obj.Count).FormulaArray = _
15
Application.WorksheetFunction.Transpose(obj.Keys)
16
End Sub
Copied!
1
Function List_Freq(rngSource As Range, _
2
Optional lngLength As Long = 5) As Variant
3
'List_Freq counts strings of lngLength subsequent
4
'cells and returns a list of sorted strings and
5
'their frequencies.
6
'Example:
7
'If A1:C2 are filled with the numbers
8
'0 1 0
9
'1 0 1
10
'then =List_Freq(A1:C2,2) array-entered in
11
'4 cells (2x2 array of cells, enter with CTRL +
12
'SHIFT + ENTER) will return
13
'01 2
14
'10 2
15
'the first column consisting of strings
16
Dim coll As New Collection
17
Dim lngFreq As Long, lngIndex As Long
18
Dim lngFound As Long
19
Dim i As Long, j As Long, k As Long
20
Dim sPattern As String
21
22
If rngSource.Columns.Count < lngLength Then
23
List_Freq = CVErr(xlErrValue)
24
Exit Function
25
End If
26
27
ReDim vA(1 To rngSource.Rows.Count * _
28
(rngSource.Columns.Count - lngLength + 1), _
29
1 To 2) As Variant
30
31
On Error Resume Next
32
33
'Count the frequencies
34
For j = 1 To rngSource.Rows.Count
35
For i = 1 To rngSource.Columns.Count - _
36
lngLength + 1
37
sPattern = rngSource.Cells(j, i)
38
For k = 1 To lngLength - 1
39
sPattern = sPattern & _
40
rngSource.Cells(j, i + k)
41
Next k
42
Err.Clear
43
lngFound = coll("X" & sPattern)
44
If Err.Number <> 0 Then
45
lngIndex = lngIndex + 1
46
coll.Add lngIndex, "X" & sPattern
47
vA(lngIndex, 1) = sPattern
48
vA(lngIndex, 2) = 1
49
Else
50
vA(lngFound, 1) = sPattern
51
vA(lngFound, 2) = vA(lngFound, 2) + 1
52
End If
53
Next i
54
Next j
55
56
'Sort output
57
For i = 1 To lngIndex
58
For j = i + 1 To lngIndex
59
If vA(i, 1) > vA(j, 1) Then
60
sPattern = vA(j, 1)
61
vA(j, 1) = vA(i, 1)
62
vA(i, 1) = sPattern
63
lngFound = vA(j, 2)
64
vA(j, 2) = vA(i, 2)
65
vA(i, 2) = lngFound
66
End If
67
Next j
68
Next i
69
70
List_Freq = vA
71
72
End Function
Copied!
Last modified 1yr ago
Copy link