CODEWITHSUNDEEP
excelvbaexcel-formula
Part_Time_Nerd
Part_Time_Nerd

Reputation: 1014

Using Excel VBA to get min and max based on criteria

I am trying to get the earliest start date (min) and the furthest end date (max) based on criteria in a source column. I have created several functions based on a solution I found on the internet. I have also tried an array formula solution without using VBA. Neither of the approaches have worked. I have found similar questions/answers on SO but none that correctly apply to my situation.

In my example below I have a Task worksheet and an Export worksheet. The Export worksheet is the source data. In the Task worksheet I am trying to enter a formula that finds the minimum start date. Each Task ID can have several dates so I am trying to find the lowest and highest start dates for each of the tasks. I originally tried using an array formula but ran into the same problem which is that sometimes the formula produces the correct answer and sometimes it gives an incorrect answer and I cannot locate the source of the issue. Any help is much appreciated!

VBA Functions:

Function getmaxvalue(Maximum_range As Range)
    Dim i As Double
        For Each cell In Maximum_range
            If cell.Value > i Then
                i = cell.Value
            End If
        Next
 getmaxvalue = i
End Function

Function getminvalue(Minimum_range As Range)
    Dim i As Double
        i = getmaxvalue(Minimum_range)
        For Each cell In Minimum_range
            If cell.Value < i Then
                i = cell.Value
            End If
        Next
 getminvalue = i
End Function

Function GetMinIf(SearchRange As Range, SearchValue As String, MinRange As Range)
Dim Position As Double
Position = 1
Dim getminvalue As Double
getminvalue = MinRange.Rows(1).Value
For Each cell In SearchRange
    If LCase(SearchValue) = LCase(cell.Value) And MinRange.Rows(Position).Value < getminvalue Then
        getminvalue = MinRange.Rows(Position).Value
    End If
Position = Position + 1
Next
GetMinIf = getminvalue
End Function

Function GetMaxIf(SearchRange As Range, SearchValue As String, MaxRange As Range)
Dim Position As Double
Position = 1
Dim getmaxvalue As Double

For Each cell In SearchRange
    If LCase(SearchValue) = LCase(cell.Value) And MaxRange.Rows(Position).Value > getmaxvalue Then
        getmaxvalue = MaxRange.Rows(Position).Value
    End If
Position = Position + 1
Next
GetMaxIf = getmaxvalue
End Function

Task Worksheet Export Worksheet

Upvotes: 0

Views: 8170

Answers (2)

David Erickson
David Erickson

Reputation: 16683

I was trying to use Scott's method as part of a macro to transform an invoice. However, the rows of the invoice fluctuate every month and could grow to as many as a million in the future. Anyway, the bottomline is that I had to write the formula in a way where I could make the last row dynamic, which made the macro go from taking 10-15 minutes (by hardcoding a static last row like 1048576 to run to ~ 1 minute to run. I reference this thread to get the idea for the MINIFS workaround and another thread to figure out how to do a dynamic last row. Make vba excel function dynamic with the reference cells

I'm sure there are other methods, perhaps using offset, etc. but I tried other methods and this one was pretty quick. Anyone can use this VBA formula if they do the following:

  • 15 to 14 to do a maxifs, keep as is for minifs
  • change the relevant rows and columns in Cells(rows, columns) format below.
  • The True/False parameters passed to .Address() will lock/unlock the rows/columns respectively (i.e. add a $ in front if True).
  • Change the last row

First, get the last row

Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Second, here is the dynamic minifs

Range("F2").Formula = "=AGGREGATE(15,7," & Range(Cells(2, 6), Cells(LastRow, 6)).Address(True, True) & "/(" & Range(Cells(2, 1), Cells(LastRow, 1)).Address(True, True) & "=" & Range(Cells(2, 1), Cells(2, 1)).Address(False, True) & "),1)"

Third, autofill down.

Range("F2").AutoFill Destination:=Range("F2:F" & LastRow)

Upvotes: 0

Scott Craner
Scott Craner

Reputation: 152475

The issue is that you are trying to equate positions incorrectly. Use this for the MinIf, it no longer needs the secondary function:

Function GetMinIf(SearchRange As Range, SearchValue As String, MinRange As Range)
    Dim srArr As Variant
    srArr = Intersect(SearchRange.Parent.UsedRange, SearchRange).Value

    Dim mrArray As Variant
    mrarr = Intersect(MinRange.Parent.UsedRange, MinRange).Value

    Dim minTemp As Double
    minTemp = 9999999999#

    Dim i As Long
    For i = 1 To UBound(srArr, 1)
        If LCase(SearchValue) = LCase(srArr(i, 1)) And mrarr(i, 1) < minTemp Then
            minTemp = mrarr(i, 1)
        End If
    Next i
    GetMinIf = minTemp
End Function

Max:

Function GetMaxIf(SearchRange As Range, SearchValue As String, MaxRange As Range)
    Dim srArr As Variant
    srArr = Intersect(SearchRange.Parent.UsedRange, SearchRange).Value

    Dim mrArray As Variant
    mrarr = Intersect(MaxRange.Parent.UsedRange, MaxRange).Value

    Dim maxTemp As Double
    maxTemp = 0

    Dim i As Long
    For i = 1 To UBound(srArr, 1)
        If LCase(SearchValue) = LCase(srArr(i, 1)) And mrarr(i, 1) > maxTemp Then
            maxTemp = mrarr(i, 1)
        End If
    Next i
    GetMaxIf = maxTemp
End Function

As far as formula go IF you have OFFICE 365 then use MINIFS

=MINIFS(Export!F:F,Export!A:A,A2)
=MAXIFS(Export!G:G,Export!A:A,A2)

If not use AGGREGATE:

=AGGREGATE(15,7,Export!$F$2:F$26/(Export!$A$2:A$26=A2),1)
=AGGREGATE(14,7,Export!$G$2:G$26/(Export!$A$2:A$26=A2),1)

Upvotes: 2

Related Questions