Array formulas are killing my CPU. Is there a better VBA solution?

[USAMax]

I have a array formulas that are killing the CPU.

The arrays are in two columns with 10,000 rows. They are comparing the worksheet with the array formulas with up another worksheet with 65,622 rows. The formulas only use the Min/Max functions.

'THIS RETURNS THE FIRST DATE THAT RELATES TO B2
=MIN(IF($B2='Costing Team (Z9QT05)'!$B:$B,'Costing Team (Z9QT05)'!$G:$G))

'THIS RETURNS THE LAST DATE THAT RELATES TO B2
=MAX(IF($B2='Costing Team (Z9QT05)'!$B:$B,'Costing Team (Z9QT05)'!$H:$H))

Is there a faster VBA code?

 

[USAMax]

Do the results need to be dynamic? That is, are the values in B2 or 'Costing Team (Z9QT05)' columns B, G, H regularly changing and you need the result of this formula to be immediately updated? If you were happy to have the results populated by vba and for them to then be static or only updated when you want them to be, then your workbook would likely be more responsive most of the time. If you are interested in pursuing this, tell us what sheet and what cells those given formulas are in and what other cells they are currently copied to. Is it down to the end of the data in column B?

Peter,

You have no idea how happy I am to here someone has a fresh solution and NO the results do not have to be dynamic.

This array formula goes into cell C2 of Quote Time.

=MIN(IF('Costing Team'!$B:$B='Quote Times'!$B2,'Costing Team'!$G:$G))

The last row will vary each month but here is what they are currently.
Costing Team has 65,000 rows
Quote Time has 11,000 rows

 

[Peter_SSs]

This array formula goes into cell C2 of Quote Time.

=MIN(IF('Costing Team'!$B:$B='Quote Times'!$B2,'Costing Team'!$G:$G))

The last row will vary each month but here is what they are currently.
Costing Team has 65,000 rows
Quote Time has 11,000 rows

Check the sheet names carefully in the code below as I wasn't sure from what you wrote above.

My sample data will no doubt be nothing like yours, but for data that size (& no other formulas in the workbook), this took less than 1 second to produce the approximately 20,000 results.

I would suggest that in a copy of your workbook you
- remove those array formulas from column C of the Quote sheet (& I assume column D for the MAX values)
- run my code (results will go into columns C:D)
- put the array formulas back in row 2 of some vacant columns and copy down a small distance, just to check that my code is producing the same results.
- report back any problems (examples)

If an item in col B of Quotes does not appear in col B of Costing, my code will leave blank for Min/Max whereas your formulas return 0 for both. Let me know if you would prefer the 0 (if it is even possible that such a circumstance can occur for you)

Sub Replace_Formulas()
  Dim DictMin As Object, DictMax As Object
  Dim a As Variant, b As Variant, aRws As Variant, aCols As Variant
  Dim i As Long, lrC As Long
 
  Set DictMin = CreateObject("Scripting.Dictionary")
  DictMin.CompareMode = 1
  Set DictMax = CreateObject("Scripting.Dictionary")
  DictMax.CompareMode = 1
  With Sheets("Costing Team")
    lrC = .Range("B" & .Rows.Count).End(xlUp).Row
    aRws = Evaluate("row(2:" & lrC & ")")
    aCols = Array(2, 7)   '<- Columns B & G
    a = Application.Index(.Cells, aRws, aCols)
  End With
  For i = 1 To UBound(a)
    If DictMin.exists(a(i, 1)) Then
      If a(i, 2) < DictMin(a(i, 1)) Then
        DictMin(a(i, 1)) = a(i, 2)
      ElseIf a(i, 2) > DictMax(a(i, 1)) Then
        DictMax(a(i, 1)) = a(i, 2)
      End If
    Else
      DictMin(a(i, 1)) = a(i, 2)
      DictMax(a(i, 1)) = a(i, 2)
    End If
  Next i
  With Sheets("Quote Times")
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 2)
    For i = 1 To UBound(a)
      If DictMin.exists(a(i, 1)) Then
        b(i, 1) = DictMin(a(i, 1))
        b(i, 2) = DictMax(a(i, 1))
      End If
    Next i
    .Range("C2:D2").Resize(UBound(b)).Value = b
  End With
End Sub

 

[USAMax]

You mean entire column. Instead of using a reference like:

[COLOR=#333333]'Costing Team (Z9QT05)'!$B:$B

you would want to use:
[/COLOR]

[COLOR=#333333]'Costing Team (Z9QT05)'!$B1:$B65622[/COLOR]

Joe,

Yes, that is what I meant. I found that Auto Fill is the fastest way to fill in the Array Formula but it gave me an out of memory error when I tried to update 65,000 rows. I divided it into four different updates and it still gave me the same error on the last one but it added the formula to the end, I just had to disable alerts.

It is currently taking an hour to update when I tell it to calculate.

 

[USAMax]

Thank you so much Peter!

From looking at your code I believe I have an idea of what you are doing but I won't be sure until I try it at work on Monday. I will gratefully share my results once I test it, sorry to say I cannot share the data as it does not belong to me.

Thank you again!

 

[USAMax]

Check the sheet names carefully in the code below as I wasn't sure from what you wrote above.

My sample data will no doubt be nothing like yours, but for data that size (& no other formulas in the workbook), this took less than 1 second to produce the approximately 20,000 results.

I would suggest that in a copy of your workbook you
- remove those array formulas from column C of the Quote sheet (& I assume column D for the MAX values)
- run my code (results will go into columns C:D)
- put the array formulas back in row 2 of some vacant columns and copy down a small distance, just to check that my code is producing the same results.
- report back any problems (examples)

If an item in col B of Quotes does not appear in col B of Costing, my code will leave blank for Min/Max whereas your formulas return 0 for both. Let me know if you would prefer the 0 (if it is even possible that such a circumstance can occur for you)

Sub Replace_Formulas()
  Dim DictMin As Object, DictMax As Object
  Dim a As Variant, b As Variant, aRws As Variant, aCols As Variant
  Dim i As Long, lrC As Long
 
  Set DictMin = CreateObject("Scripting.Dictionary")
  DictMin.CompareMode = 1
  Set DictMax = CreateObject("Scripting.Dictionary")
  DictMax.CompareMode = 1
  With Sheets("Costing Team")
    lrC = .Range("B" & .Rows.Count).End(xlUp).Row
    aRws = Evaluate("row(2:" & lrC & ")")
    aCols = Array(2, 7)   '<- Columns B & G
    a = Application.Index(.Cells, aRws, aCols)
  End With
  For i = 1 To UBound(a)
    If DictMin.exists(a(i, 1)) Then
      If a(i, 2) < DictMin(a(i, 1)) Then
        DictMin(a(i, 1)) = a(i, 2)
      ElseIf a(i, 2) > DictMax(a(i, 1)) Then
        DictMax(a(i, 1)) = a(i, 2)
      End If
    Else
      DictMin(a(i, 1)) = a(i, 2)
      DictMax(a(i, 1)) = a(i, 2)
    End If
  Next i
  With Sheets("Quote Times")
    a = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 2)
    For i = 1 To UBound(a)
      If DictMin.exists(a(i, 1)) Then
        b(i, 1) = DictMin(a(i, 1))
        b(i, 2) = DictMax(a(i, 1))
      End If
    Next i
    .Range("C2:D2").Resize(UBound(b)).Value = b
  End With
End Sub

Peter, I cannot follow what you are doing but it looks like it is making changes to the Costing Team and Quote Times worksheet while I need it to update a new, unnamed, worksheet from the details on those two sheets. I don't want to change those worksheets as they are only there for reference.

On the unnamed adhoc worksheet I have the formula in C2 and it is looking for a match with B2 of the Quote Time worksheet.

=MIN(IF('Costing Team'!$B:$B='Quote Times'!$B2,'Costing Team'!$G:$G))

 

[Peter_SSs]

Best not to fully quote long posts as it makes the thread harder to read/navigate and just occupies storage space needlessly. If you want to quote, quote small, relevant parts only.

... it looks like it is making changes to the Costing Team and Quote Times worksheet ....

"looks like"?
Are you judging that from reading the code or from looking at the result after running it on a copy of your file?

It isn't surprising that it is changing Quote Times, after all the object was to replace a whole bunch of array formulas and you said (post 11) that they were in column C of that sheet.
The code makes no change to Costing Team.

.. I need it to update a new, unnamed, worksheet from the details on those two sheets.

On the unnamed adhoc worksheet I have the formula in C2 and it is looking for a match with B2 of the Quote Time worksheet.

What details? All you have indicated so far is a formula in column C.
Is the code supposed to be entering other details? If so, I'd clearly need to know what they are.
A sheet cannot be "unnamed", so whether it already exists & the code is just adding to it, or the code is to create it and add to it, it will need a name. If it already exists, what is its name? If it doesn't, what would you like its name to be?

 

[USAMax]

Peter,

I am sorry about the delay in my response. The values need to go into column C of the active sheet, the sheet's name will change so I hesitate to give you a name but if you have to have a name let's call it Sheet1. It will be getting the data from sheet, "Costing Team (Z9QT05)" as you already have coded.

Just adding the array formula takes an hour and it has to be run several times so I cannot thank you enough for your help!

 

[Peter_SSs]

The values need to go into column C of the active sheet,...

In that case, would the simple addition of the blue text below produce what you want?

    Next i
    ActiveSheet.Range("C2:D2").Resize(UBound(b)).Value = b
  End With