1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
| Option Explicit
Option Base 1
Public Function MEDIANIF(ByVal rgeCriteria As Range, _
ByVal sCriteria As String, _
ByVal rgeMedianRange As Range) As Single
Dim iconditioncolno As Integer
Dim inumberscolno As Integer
Dim lrowno As Long
Dim lmatch As Long
Dim arsngvalues() As Single
Dim sngmedian As Single
Dim bsorted As Boolean
Dim vcellvalue As Variant
Call Application.Volatile(True)
iconditioncolno = rgeCriteria.Column
inumberscolno = rgeMedianRange.Column
ReDim arsngvalues(rgeCriteria.Rows.Count)
For lrowno = 1 To rgeCriteria.Rows.Count
vcellvalue = rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, inumberscolno).Value
If rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, iconditioncolno).Value = sCriteria And _
IsNumeric(vcellvalue) = True Then
lmatch = lmatch + 1
arsngvalues(lmatch) = rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, inumberscolno).Value
End If
If lmatch > 0 And IsEmpty(vcellvalue) = True Then Exit For
Next lrowno
ReDim Preserve arsngvalues(lmatch)
Do
bsorted = True
For lrowno = 2 To lmatch
If arsngvalues(lrowno - 1) > arsngvalues(lrowno) Then
sngmedian = arsngvalues(lrowno - 1)
arsngvalues(lrowno - 1) = arsngvalues(lrowno)
arsngvalues(lrowno) = sngmedian
bsorted = False
End If
Next lrowno
Loop Until bsorted = True
If lmatch Mod 2 = 0 Then MEDIANIF = (arsngvalues(CInt(lmatch / 2)) + arsngvalues(1 + CInt(lmatch / 2))) / 2
If lmatch Mod 2 = 1 Then MEDIANIF = arsngvalues((lmatch + 1) / 2)
End Function
|
