Sulprobil
Search…
Pfreq
Pfreq lists frequencies of input combinations:
Examples:
Please note that I do not recommend to use the Pfreq(Pfreq(...)) approach for more than some thousand rows: For 10,000 rows and two columns it takes more than 1 minute to calculate on my dual core computer!
If you need a sorted output you can take my UDF GSort.
Please read my Disclaimer.
1
Function Pfreq(ParamArray v()) As Variant
2
'Pfreq lists how often each value combination
3
'in paramarray appears. Example:
4
' A B
5
' 1 Smith Adam
6
' 2 Myer Ben
7
' 3 Smith Ben
8
' 4 Smith Adam
9
' 5 Myer Ben
10
'Now select C1:E3 and array-enter
11
'=Pfreq(A1:A5,B1:B5) and you will get
12
' C D E
13
' 1 Smith Adam 2
14
' 2 Myer Ben 2
15
' 3 Smith Ben 1
16
'Reverse("moc.liborplus.www") V0.4 15-Oct-2009
17
Dim obj As Object
18
Dim vR As Variant
19
Dim i As Long, j As Long, k As Long, lvdim As Long
20
Dim s As String, sC As String
21
22
With Application.WorksheetFunction
23
sC = "|"
24
Set obj = CreateObject("Scripting.Dictionary")
25
k = 0
26
v(0) = .Transpose(.Transpose(v(0)))
27
lvdim = UBound(v(0))
28
If lvdim > 100 Then lvdim = 100
29
On Error GoTo ErrHdl
30
ReDim vR(0 To UBound(v) + 1, 1 To lvdim)
31
For i = 1 To UBound(v(0))
32
s = v(0)(i, 1)
33
For j = 1 To UBound(v)
34
v(j) = .Transpose(.Transpose(v(j)))
35
s = s & sC & v(j)(i, 1)
36
Next j
37
If obj.Item(s) > 0 Then
38
vR(UBound(v) + 1, obj.Item(s)) = vR(UBound(v) + 1, obj.Item(s)) + 1
39
Else
40
k = k + 1
41
obj.Item(s) = k
42
For j = 0 To UBound(v)
43
vR(j, k) = v(j)(i, 1)
44
Next j
45
vR(UBound(v) + 1, k) = 1
46
End If
47
Next i
48
If k > 0 Then ReDim Preserve vR(0 To UBound(v) + 1, 1 To k)
49
Pfreq = .Transpose(vR)
50
End With
51
Exit Function
52
ErrHdl:
53
If Err.Number = 9 Then
54
If i > lvdim Then
55
'Here we normally get if we breach Ubound(vR,2)
56
'So we need to increase last dimension
57
lvdim = 10 * lvdim
58
If lvdim > UBound(v(0)) Then lvdim = UBound(v(0))
59
ReDim Preserve vR(0 To UBound(v) + 1, 1 To lvdim)
60
Err.Number = 0
61
Resume 'Back to statement which caused error
62
End If
63
End If
64
'Other error - terminate
65
On Error GoTo 0
66
Resume
67
End Function
Copied!
Last modified 1yr ago
Copy link