MAXVISIBLEIFS

Returns the largest value from only the visible, non blank cells that satisfy multiple conditions.


Remarks

* This function excludes hidden cells.
* You can use the MAXIFS function to include hidden cells.
* For instructions on how to add a function to a workbook refer to the page under Inserting Functions
* The equivalent JavaScript function is MAXVISIBLEIFS


Public Function MAXVISIBLEIFS(ByVal rgeMaxRange As Range, _ 
                        ParamArray avCriteriaAndRanges() As Variant) As Variant
                          
Dim avCriterias() As Range
Dim asCriterias() As String
Dim icriteriacount As Integer
Dim rgeCriteria As Range
Dim sCriteria As String
Dim iitemcount 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

   If UBound(avCriteriaAndRanges, 1) Mod 2 > 0 Then
'not the correct amount of arguments
   End If

   ReDim avCriterias(UBound(avCriteriaAndRanges, 1))
   ReDim asCriterias(UBound(avCriteriaAndRanges, 1))
   icriteriacount = 1

   For iitemcount = 0 To UBound(avCriteriaAndRanges, 1) Step 2
     
      If TypeName(avCriteriaAndRanges(iitemcount)) = "Range" Then
         sCriteria = CStr(avCriteriaAndRanges(iitemcount).Value)
      End If
      If TypeName(avCriteriaAndRanges(iitemcount)) = "Boolean" Then
         sCriteria = CStr(CBool(avCriteriaAndRanges(iitemcount)))
      End If
      If TypeName(avCriteriaAndRanges(iitemcount)) = "String" Then
         sCriteria = CStr(avCriteriaAndRanges(iitemcount))
      End If
      
      If TypeName(avCriteriaAndRanges(iitemcount + 1)) = "Range" Then
         Set rgeCriteria = avCriteriaAndRanges(iitemcount + 1)
      End If
      
      Set avCriterias(icriteriacount) = rgeCriteria
      asCriterias(icriteriacount) = sCriteria
      icriteriacount = icriteriacount + 1
   Next iitemcount
   
   ReDim Preserve avCriterias(icriteriacount - 1)
   ReDim Preserve asCriterias(icriteriacount - 1)
      
'must all have the same number of rows
   ReDim arsngvalues(avCriterias(1).Rows.Count)
        
   For lrowno = 1 To rgeCriteria.Rows.Count
      vcellvalue = rgeCriteria.Parent.Cells(rgeCriteria.Row + lrowno - 1, rgeMaxRange.Column).Value
      
      If Row_MatchesAllCriteria(lrowno, avCriterias, asCriterias) = True And _
         IsNumeric(vcellvalue) = True Then
         
         lmatch = lmatch + 1
         arsngvalues(lmatch) = rgeMaxRange.Parent.Cells(rgeMaxRange.Row + lrowno - 1, rgeMaxRange.Column).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
      
   MAXVISIBLEIFS = arsngvalues(lmatch)
End Function

Public Function Row_MatchesAllCriteria(ByVal lrowno As Long, _
                                       ByVal vArrayCriteria As Variant, _
                                       ByVal sArrayCriteria As Variant) As Boolean

Dim avCriterias() As Range
Dim asCriterias() As String
Dim rgeCriteria As Range
Dim sCriteria As String

Dim iitemcount As Integer
Dim bmatch As Boolean
Dim iconditioncolno As Integer
Dim icriteriacount As Integer

   ReDim avCriterias(UBound(vArrayCriteria, 1))
   ReDim asCriterias(UBound(sArrayCriteria, 1))

   For iitemcount = 1 To UBound(vArrayCriteria, 1)
      If TypeName(vArrayCriteria(iitemcount)) = "Range" Then
         Set rgeCriteria = vArrayCriteria(iitemcount)
      End If
      If TypeName(sArrayCriteria(iitemcount)) = "String" Then
         sCriteria = CStr(sArrayCriteria(iitemcount))
      End If

      Set avCriterias(iitemcount) = rgeCriteria
      asCriterias(iitemcount) = sCriteria
   Next iitemcount

   bmatch = True
   For icriteriacount = 1 To UBound(avCriterias, 1)
      iconditioncolno = avCriterias(icriteriacount).Column
            
      Dim tempCondition As String
      Dim tempCellValue As String
      tempCondition = asCriterias(icriteriacount)
'check the symbol and add the default equals if not there
      If ((Left(tempCondition, 1) <> "<") And _
          (Left(tempCondition, 1) <> ">")) Then
          
         If (Left(tempCondition, 1) <> "=") Then tempCondition = "=" & tempCondition
      End If
      
      tempCellValue = avCriterias(icriteriacount).Parent.Cells(avCriterias(icriteriacount).Row + lrowno - 1, iconditioncolno).Value
      If (Criteria_Check(tempCondition, tempCellValue) = True) Then
      Else
         bmatch = False
      End If
        
   Next icriteriacount
        
   Row_MatchesAllCriteria = bmatch
End Function

Public Function Criteria_Check(ByVal sCriteria As String, _
                               ByVal sValue As String) As Boolean
    
    If ((InStr(sCriteria, "*") > 0) And (InStr(sCriteria, "~*") = 0)) Or _
       ((InStr(sCriteria, "?") > 0) And (InStr(sCriteria, "~?") = 0)) Then
        If (Left(sCriteria, 1) = "=") Then sCriteria = Right(sCriteria, Len(sCriteria) - 1)
        Criteria_Check = (sValue Like sCriteria)
        Exit Function
    End If
    If (Left(sCriteria, 1) = "=") Then
        Criteria_Check = (sValue = Right(sCriteria, Len(sCriteria) - 1))
        Exit Function
    End If
    If (Left(sCriteria, 1) = ">") And _
       (Left(sCriteria, 2) <> ">=") Then
        Criteria_Check = (CSng(sValue) > CSng(Right(sCriteria, Len(sCriteria) - 1)))
        Exit Function
    End If
    If (Left(sCriteria, 1) = "<") And _
       (Left(sCriteria, 2) <> "<=") And (Left(sCriteria, 2) <> "<>") Then
        Criteria_Check = (CSng(sValue) < CSng(Right(sCriteria, Len(sCriteria) - 1)))
        Exit Function
    End If
    If (Left(sCriteria, 2) = ">=") Then
        Criteria_Check = (CSng(sValue) >= CSng(Right(sCriteria, Len(sCriteria) - 2)))
        Exit Function
    End If
    If (Left(sCriteria, 2) = "<=") Then
        Criteria_Check = (CSng(sValue) <= CSng(Right(sCriteria, Len(sCriteria) - 2)))
        Exit Function
    End If
    If (Left(sCriteria, 2) = "<>") Then
        Criteria_Check = (CSng(sValue) <> CSng(Right(sCriteria, Len(sCriteria) - 2)))
        Exit Function
    End If
    Criteria_Check = sValue Like sCriteria
End Function


© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext