 |
|
|
Got any Excel Questions? Excel Help .
NEW & FREE! Excel Custom Functions Add-in (has this and many other functions within) | Excel List to Table Creator Create an classic Excel table from data in a single column list. | Fill Blanks Excel Add-in Fill blanks in a list with the cell above
This Custom Function for pre Excel 2007. If you have Excel 2007, use SUMIFS. It allows you to nominate up to 5 conditions/criteria to be met in corresponding columns. As with nearly all Custom Functions for Excel, it's pays to keep the range used as small as possible. It also pays to use the 1st criteria (Criteria1) as an equal to. E.g 3 OR cat
Function SumByCriteria(Sum_Range As Range, Criteria1, Criteria1Range As Range, _
Criteria2 As String, Criteria2Range As Range, Optional Criteria3 As String, _
Optional Criteria3Range As Range, Optional Criteria4 As String, _
Optional Criteria4Range As Range, Optional Criteria5 As String, _
Optional Criteria5Range As Range) As Long
Dim lLoopStop As Long, lLoop As Long, rRange As Range, lRow As Long
Dim sTotal As Single, bVal1 As Boolean, bVal2 As Boolean, bVal3 As Boolean
Dim bVal4 As Boolean, bVal5 As Boolean, bVal1b As Boolean, bVal2b As Boolean, bVal3b As Boolean
Dim bVal4b As Boolean, bVal5b As Boolean, lCriteriaUsed As Long
Dim strCriteria1 As String, strCriteria2 As String, strCriteria3 As String, strCriteria4 As String, strCriteria5 As String
Dim rCell As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''Written by ozgrid.com''''''''''''''''''''''''''''''''''''''
'Sums Values in Sum_Range when up to 5 conditions are met in corresponding cells.
'As with nearly all Custom Functions for Excel, it's pays to keep the range used as _
small as possible. It also pays to use the 1st criteria (Criteria1) as an equal to. E.g 3 OR cat
''IF YOU HAVE 2007 USE SUMIFS
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
lLoopStop = WorksheetFunction.CountIf(Criteria1Range, Criteria1)
bVal3 = Not Criteria3Range Is Nothing
bVal4 = Not Criteria4Range Is Nothing
bVal5 = Not Criteria5Range Is Nothing
If bVal5 = False Then lCriteriaUsed = 4
If bVal4 = False Then lCriteriaUsed = 3
If bVal3 = False Then lCriteriaUsed = 2
strCriteria1 = Criteria1
strCriteria2 = Criteria2
strCriteria3 = Criteria3
strCriteria4 = Criteria4
strCriteria5 = Criteria5
If InStr(1, Criteria1, ">") + InStr(1, Criteria1, "<") = 0 Then
Set rRange = Criteria1Range(1, 1)
For lLoop = 1 To lLoopStop 'Fast loop
Set rRange = Criteria1Range.Find(Criteria1, rRange, _
xlFormulas, xlWhole, xlByRows, xlNext, False)
lRow = rRange.Row
'Criteria 5 evaluation
If bVal5 = True Then
If InStr(1, Criteria5, ">") + InStr(1, Criteria5, "<") = 0 Then
Criteria5 = Replace(Criteria5, "=", "")
If IsNumeric(Criteria5) Then
bVal5b = Criteria5Range(lRow, 1) = Val(Criteria5)
Else
bVal5b = Criteria5Range(lRow, 1) = Criteria5
End If
ElseIf InStr(1, Criteria5, ">=") <> 0 Then
Criteria5 = Replace(Criteria5, ">=", "")
bVal5b = Val(Criteria5) >= Criteria5Range(lRow, 1)
ElseIf InStr(1, Criteria5, "<=") <> 0 Then
Criteria5 = Replace(Criteria5, "<=", "")
bVal5b = Val(Criteria5) <= Criteria5Range(lRow, 1)
ElseIf InStr(1, Criteria5, ">") <> 0 Then
Criteria5 = Replace(Criteria5, ">", "")
bVal5b = Val(Criteria5) > Criteria5Range(lRow, 1)
Else
Criteria5 = Replace(Criteria5, "<", "")
bVal5b = Val(Criteria5) < Criteria5Range(lRow, 1)
End If
End If
If bVal4 = True Then
'Criteria 4 evaluation
If InStr(1, Criteria4, ">") + InStr(1, Criteria4, "<") = 0 Then
Criteria4 = Replace(Criteria4, "=", "")
If IsNumeric(Criteria4) Then
bVal4b = Criteria4Range(lRow, 1) = Val(Criteria4)
Else
bVal4b = Criteria4Range(lRow, 1) = Criteria4
End If
ElseIf InStr(1, Criteria4, ">=") <> 0 Then
Criteria4 = Replace(Criteria4, ">=", "")
bVal4b = Criteria4Range(lRow, 1) >= Val(Criteria4)
ElseIf InStr(1, Criteria4, "<=") <> 0 Then
Criteria4 = Replace(Criteria4, "<=", "")
bVal4b = Criteria4Range(lRow, 1) <= Val(Criteria4)
ElseIf InStr(1, Criteria4, ">") <> 0 Then
Criteria4 = Replace(Criteria4, ">", "")
bVal4b = Criteria4Range(lRow, 1) > Val(Criteria4)
Else
Criteria4 = Replace(Criteria4, "<", "")
bVal4b = Criteria4Range(lRow, 1) < Val(Criteria4)
End If
End If
If bVal3 = True Then
'Criteria 3 evaluation
If InStr(1, Criteria3, ">") + InStr(1, Criteria3, "<") = 0 Then
Criteria3 = Replace(Criteria3, "=", "")
If IsNumeric(Criteria3) Then
bVal3b = Criteria3Range(lRow, 1) = Val(Criteria3)
Else
bVal3b = Criteria3Range(lRow, 1) = Criteria3
End If
ElseIf InStr(1, Criteria3, ">=") <> 0 Then
Criteria3 = Replace(Criteria3, ">=", "")
bVal3b = Criteria3Range(lRow, 1) >= Val(Criteria3)
ElseIf InStr(1, Criteria3, "<=") <> 0 Then
Criteria3 = Replace(Criteria3, "<=", "")
bVal3b = Criteria3Range(lRow, 1) <= Val(Criteria3)
ElseIf InStr(1, Criteria3, ">") <> 0 Then
Criteria3 = Replace(Criteria3, ">", "")
bVal3b = Criteria3Range(lRow, 1) > Val(Criteria3)
Else
Criteria3 = Replace(Criteria3, "<", "")
If bVal3 = True Then bVal3b = Criteria3Range(lRow, 1) < Val(Criteria3)
End If
End If
'Criteria 2 evaluation
If InStr(1, Criteria2, ">") + InStr(1, Criteria2, "<") = 0 Then
Criteria2 = Replace(Criteria2, "=", "")
If IsNumeric(Criteria2) Then
bVal2b = Criteria2Range(lRow, 1) = Val(Criteria2)
Else
bVal2b = Criteria2Range(lRow, 1) = Criteria2
End If
ElseIf InStr(1, Criteria2, ">=") <> 0 Then
Criteria2 = Replace(Criteria2, ">=", "")
bVal2b = Criteria2Range(lRow, 1) >= Val(Criteria2)
ElseIf InStr(1, Criteria2, "<=") <> 0 Then
Criteria2 = Replace(Criteria2, "<=", "")
bVal2b = Criteria2Range(lRow, 1) <= Val(Criteria2)
ElseIf InStr(1, Criteria2, ">") <> 0 Then
Criteria2 = Replace(Criteria2, ">", "")
bVal2b = Criteria2Range(lRow, 1) > Val(Criteria2)
Else
Criteria2 = Replace(Criteria2, "<", "")
bVal2b = Criteria2Range(lRow, 1) < Val(Criteria2)
End If
'Criteria 1 evaluation
If InStr(1, Criteria1, ">") + InStr(1, Criteria1, "<") = 0 Then
Criteria1 = Replace(Criteria1, "=", "")
If IsNumeric(Criteria1) Then
bVal1b = Criteria1Range(lRow, 1) = Val(Criteria1)
Else
bVal1b = Criteria1Range(lRow, 1) = Criteria1
End If
ElseIf InStr(1, Criteria1, ">=") <> 0 Then
Criteria1 = Replace(Criteria1, ">=", "")
bVal1b = Criteria1Range(lRow, 1) >= Val(Criteria1)
ElseIf InStr(1, Criteria1, "<=") <> 0 Then
Criteria1 = Replace(Criteria1, "<=", "")
bVal1b = Criteria1Range(lRow, 1) <= Val(Criteria1)
ElseIf InStr(1, Criteria1, ">") <> 0 Then
Criteria1 = Replace(Criteria1, ">", "")
bVal1b = Criteria1Range(lRow, 1) > Val(Criteria1)
Else
Criteria1 = Replace(Criteria1, "<", "")
bVal1b = Criteria1Range(lRow, 1) < Val(Criteria1)
End If
If lCriteriaUsed > 4 Then
If bVal5b And bVal4b And bVal3b And bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf lCriteriaUsed > 3 Then
If bVal4b And bVal3b And bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf lCriteriaUsed > 2 Then
If bVal3b And bVal2 And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
Criteria1 = strCriteria1
Criteria2 = strCriteria2
Criteria3 = strCriteria3
Criteria4 = strCriteria4
Criteria5 = strCriteria5
Next lLoop
Else 'Slower loop through ALL rows
For Each rCell In Criteria1Range
lRow = rCell.Row
'Criteria 5 evaluation
If bVal5 = True Then
If InStr(1, Criteria5, ">") + InStr(1, Criteria5, "<") = 0 Then
Criteria5 = Replace(Criteria5, "=", "")
If IsNumeric(Criteria5) Then
bVal5b = Criteria5Range(lRow, 1) = Val(Criteria5)
Else
bVal5b = Criteria5Range(lRow, 1) = Criteria5
End If
ElseIf InStr(1, Criteria5, ">=") <> 0 Then
Criteria5 = Replace(Criteria5, ">=", "")
bVal5b = Criteria5Range(lRow, 1) >= Val(Criteria5)
ElseIf InStr(1, Criteria5, "<=") <> 0 Then
Criteria5 = Replace(Criteria5, "<=", "")
bVal5b = Criteria5Range(lRow, 1) <= Val(Criteria5)
ElseIf InStr(1, Criteria5, ">") <> 0 Then
Criteria5 = Replace(Criteria5, ">", "")
bVal5b = Criteria5Range(lRow, 1) > Val(Criteria5)
Else
Criteria5 = Replace(Criteria5, "<", "")
bVal5b = Criteria5Range(lRow, 1) < Val(Criteria5)
End If
End If
If bVal4 = True Then
'Criteria 4 evaluation
If InStr(1, Criteria4, ">") + InStr(1, Criteria4, "<") = 0 Then
Criteria4 = Replace(Criteria4, "=", "")
If IsNumeric(Criteria4) Then
bVal4b = Criteria4Range(lRow, 1) = Val(Criteria4)
Else
bVal4b = Criteria4Range(lRow, 1) = Criteria4
End If
ElseIf InStr(1, Criteria4, ">=") <> 0 Then
Criteria4 = Replace(Criteria4, ">=", "")
bVal4b = Criteria4Range(lRow, 1) >= Val(Criteria4)
ElseIf InStr(1, Criteria4, "<=") <> 0 Then
Criteria4 = Replace(Criteria4, "<=", "")
bVal4b = Criteria4Range(lRow, 1) <= Val(Criteria4)
ElseIf InStr(1, Criteria4, ">") <> 0 Then
Criteria4 = Replace(Criteria4, ">", "")
bVal4b = Criteria4Range(lRow, 1) > Val(Criteria4)
Else
Criteria4 = Replace(Criteria4, "<", "")
bVal4b = Criteria4Range(lRow, 1) < Val(Criteria4)
End If
End If
If bVal3 = True Then
'Criteria 3 evaluation
If InStr(1, Criteria3, ">") + InStr(1, Criteria3, "<") = 0 Then
Criteria3 = Replace(Criteria3, "=", "")
If IsNumeric(Criteria3) Then
bVal3b = Criteria3Range(lRow, 1) = Val(Criteria3)
Else
bVal3b = Criteria3Range(lRow, 1) = Criteria3
End If
ElseIf InStr(1, Criteria3, ">=") <> 0 Then
Criteria3 = Replace(Criteria3, ">=", "")
bVal3b = Criteria3Range(lRow, 1) >= Val(Criteria3)
ElseIf InStr(1, Criteria3, "<=") <> 0 Then
Criteria3 = Replace(Criteria3, "<=", "")
bVal3b = Criteria3Range(lRow, 1) <= Val(Criteria3)
ElseIf InStr(1, Criteria3, ">") <> 0 Then
Criteria3 = Replace(Criteria3, ">", "")
bVal3b = Criteria3Range(lRow, 1) > Val(Criteria3)
Else
Criteria3 = Replace(Criteria3, "<", "")
If bVal3 = True Then bVal3b = Criteria3Range(lRow, 1) < Val(Criteria3)
End If
End If
'Criteria 2 evaluation
If InStr(1, Criteria2, ">") + InStr(1, Criteria2, "<") = 0 Then
Criteria2 = Replace(Criteria2, "=", "")
If IsNumeric(Criteria2) Then
bVal2b = Criteria2Range(lRow, 1) = Val(Criteria2)
Else
bVal2b = Criteria2Range(lRow, 1) = Criteria2
End If
ElseIf InStr(1, Criteria2, ">=") <> 0 Then
Criteria2 = Replace(Criteria2, ">=", "")
bVal2b = Criteria2Range(lRow, 1) >= Val(Criteria2)
ElseIf InStr(1, Criteria2, "<=") <> 0 Then
Criteria2 = Replace(Criteria2, "<=", "")
bVal2b = Criteria2Range(lRow, 1) <= Val(Criteria2)
ElseIf InStr(1, Criteria2, ">") <> 0 Then
Criteria2 = Replace(Criteria2, ">", "")
bVal2b = Criteria2Range(lRow, 1) > Val(Criteria2)
Else
Criteria2 = Replace(Criteria2, "<", "")
bVal2b = Criteria2Range(lRow, 1) < Val(Criteria2)
End If
'Criteria 1 evaluation
If InStr(1, Criteria1, ">") + InStr(1, Criteria1, "<") = 0 Then
Criteria1 = Replace(Criteria1, "=", "")
If IsNumeric(Criteria1) Then
bVal1b = Criteria1Range(lRow, 1) = Val(Criteria1)
Else
bVal1b = Criteria1Range(lRow, 1) = Criteria1
End If
ElseIf InStr(1, Criteria1, ">=") <> 0 Then
Criteria1 = Replace(Criteria1, ">=", "")
bVal1b = Criteria1Range(lRow, 1) >= Val(Criteria1)
ElseIf InStr(1, Criteria1, "<=") <> 0 Then
Criteria1 = Replace(Criteria1, "<=", "")
bVal1b = Criteria1Range(lRow, 1) <= Val(Criteria1)
ElseIf InStr(1, Criteria1, ">") <> 0 Then
Criteria1 = Replace(Criteria1, ">", "")
bVal1b = Criteria1Range(lRow, 1) > Val(Criteria1)
Else
Criteria1 = Replace(Criteria1, "<", "")
bVal1b = Criteria1Range(lRow, 1) < Val(Criteria1)
End If
If lCriteriaUsed > 4 Then
If bVal5b And bVal4b And bVal3b And bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf lCriteriaUsed > 3 Then
If bVal4b And bVal3b And bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf lCriteriaUsed > 2 Then
If bVal3b And bVal2 And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
Criteria1 = strCriteria1
Criteria2 = strCriteria2
Criteria3 = strCriteria3
Criteria4 = strCriteria4
Criteria5 = strCriteria5
Next rCell
End If
SumByCriteria = sTotal
End Function
=SumByCriteria(A1:A21,"cat",C1:C21,"furry",E1:E21,"fluffy",G1:G21,"persian",I1:I21)
Note this only uses 4 criteria, not 5. The 1st 2 criteria are mandatory (if you only need 1, use SUMIF) while the last 3 are optional
Excel Dashboard Reports & Excel Dashboard Charts 50% Off
Become an ExcelUser Affiliate & Earn Money
Special! Free Choice of Complete Excel Training Course OR Excel Add-ins Collection on all purchases totaling over $64.00. ALL purchases totaling over $150.00 gets you BOTH! Purchases MUST be made via this site. Send payment proof to [email protected] 31 days after purchase date.
Instant Download and Money Back Guarantee on Most Software
Excel Trader Package Technical Analysis in Excel With $139.00 of FREE software!
Microsoft � and Microsoft Excel � are registered trademarks of Microsoft Corporation. OzGrid is in no way associated with Microsoft
GIVE YOURSELF OR YOUR COMPANY 24/7 MICROSOFT EXCEL SUPPORT & QUESTIONS