Array calculations instead of SUMPRODUCT

A

aethere92

New Member
Joined
Aug 23, 2017
Messages
6
Hello,

I have a workbook I'm using as a tracker of how many tasks were done in each day of the year. Each week has its own worksheet (and is named by the week's number - e.g. "35" if the dates covered are between the 21st and 27th of August).

(Tracker sheet)
[TABLE="class: grid, width: 35"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Tasks/Date[/TD]
[TD="align: center"]21/08/2017[/TD]
[TD="align: center"]22/08/2017[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Task_1[/TD]
[TD]=SUMPRODUCT(('35'!$C$1:$E$4=$A2)*('35'!$A$1:$A$4=B$1))[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Task_2[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

(week "35" sheet)
[TABLE="class: grid, width: 50, align: left"]
<tbody>[TR]
[TD="align: center"][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]E[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]21/08/2017[/TD]
[TD]08:00[/TD]
[TD][/TD]
[TD]Task_1[/TD]
[TD]Task_2[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]21/08/2017[/TD]
[TD]09:00[/TD]
[TD]Task_2[/TD]
[TD]Task_1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]22/08/2017[/TD]
[TD]08:00[/TD]
[TD]Task_1[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]22/08/2017[/TD]
[TD]09:00[/TD]
[TD]Task_2[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]









So what I need to do is track how many times in each day each task appears. The SUMPRODUCT formula I've listed in B2 in the Tracker sheet works just fine, however, it is very slow.

I've managed to make it work with VBA by using the Cell.Value2 = Evaluate, but it still takes like 5-6 seconds to do it, and from what I've read, doing the calculations in an array and them pasting the results to the table should take way less than that.

The exact code for the evaluate is as follows:
Code: 
Set rng = Sheets("Tracker").Range("D6:EM" & Range("C999").End(xlUp).Row)

For Each cell In rng
If Not Cells(cell.Row, 3).Value Like "*Planned*" And Not Cells(cell.Row, 3).Value Like "*all_*" And (Cells(cell.Row, 3).Value Like "X1_*" Or Cells(cell.Row, 3).Value Like "PM_*") Then
    cell.Value2 = Evaluate("IFERROR(SUMPRODUCT((" & Cells(1, cell.Column).Value & "!$F$6:$BM$102=" & Cells(cell.Row, 3).Address & ")*(" & Cells(1, cell.Column).Value & "!$D$6:$D$102=" & Cells(4, cell.Column).Address & "))/8,0)")
End If
Next

One thing, the format needs to stay this way, and I cannot use PivotTables...

I'd really appreciate if anyone could help me with a solution to reduce the calculation times on this.

Thanks!
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
Should be do-able in an array, though what's in B2 doesn't seem like the formula in your code being evaluated, e.g. $C$1:$E$4=$A2 vs code of $F$6:$BM$102

Can you confirm the exact formula that should be evaluated? Also B2 is not D6 (first cell in the set rng) so where is the formula meant to go?
 
Last edited:
Upvote 0
Hey,

The formula I'm working with is the one within the code tags:
Code: 
Set rng = Sheets("Tracker").Range("D6:EM" & Range("C999").End(xlUp).Row)


For Each cell In rng
If Not Cells(cell.Row, 3).Value Like "*Planned*" And Not Cells(cell.Row, 3).Value Like "*all_*" And (Cells(cell.Row, 3).Value Like "X1_*" Or Cells(cell.Row, 3).Value Like "PM_*") Then
    cell.Value2 = Evaluate("IFERROR(SUMPRODUCT((" & Cells(1, cell.Column).Value & "!$F$6:$BM$102=" & Cells(cell.Row, 3).Address & ")*(" & Cells(1, cell.Column).Value & "!$D$6:$D$102=" & Cells(4, cell.Column).Address & "))/8,0)")
End If
Next

What I had posted in the tables was a mock-up of how my data actually looks and what the SUMPRODUCT formula that I'm trying to replicate via arrays looked like.

I'm sorry for the confusion.
 
Upvote 0
Can you post the exact formula that would appear in the cell, if you weren't using VBA.

It's much easier if you're precise, it makes it easier to suggest solutions since readers of the thread can't see your PC monitor if you do not show screenshots either.

Also, 52 weeks in a year suggest a final column of BC from column D, yet your range is set to EM, suggesting 140 weeks which is more than 1 year?
 
Upvote 0
Best guess and untested, replace all of your code with:
Code: 
Sub Macro1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant

    With Sheets("Tracker")
        x = .Cells(.Rows.Count, 3).End(xlUp).row
        arr = .Cells(1, 4).Resize(x, 140).Value

        For x = LBound(arr, 1) + 5 To UBound(arr, 1)
            For y = LBound(arr, 2) + 5 To UBound(arr, 2)
                If InStr(arr(x, 3), "XL_") + InStr(arr(x, 3), "PM_") Then arr(x, y) = MySUMPRODUCT(Sheets(CStr(arr(x, 3)), CStr(arr(x, 3)), CStr(arr(1, y))))
            Next y
        Next x

        .Cells(1, 4).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    Erase arr

End Sub


Private Function MySUMPRODUCT(ByRef wks As Worksheet, ByRef x As String, ByRef y As String) As Long

    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    MySUMPRODUCT = 0
    
    With wks
        arr = .Cells(6, 4).Resize(97, 140).Value
        For x = LBound(arr, 1) + 2 To UBound(arr, 1)
            For y = LBound(arr, 2) To UBound(arr, 2)
                On Error Resume Next
                MySUMPRODUCT = MySUMPRODUCT - (InStr(CStr(arr(x, y)), x) > 0) - (InStr(CStr(arr(x, l)), y) > 0)
                On Error GoTo 0
            Next y
        Next x
    End With
    Erase arr
    
    MySUMPRODUCT = MySUMPRODUCT * 0.125
    
End Function
Suggest testing on a copy of your workbook first.
 
Last edited:
Upvote 0
Hello,

I made a quick mock-up of how the actual document looks like (since I can't share that one) - the concept is the same - we have a column with each task, and the rest of the table is arranged with dates (right now, our document is set from 28th of August to the 31st of December 2017, but that might change, so I need to be able to adjust the range it does the calculations on).

Mockup_aethere92.xlsx - Google Drive

Speaking solely on the mock-up - sheet "Tracker" does the actual tracking, the formula used in cell C5 is
Code: 
=IFERROR(SUMPRODUCT((INDIRECT(C$2&"!$F$6:$BM$102")=Tracker!$B5)*(INDIRECT(C$2&"!$D$6:$D$102")=Tracker!C$4))/8,0)
I wrote it that way so I can easily drag it across and have it reference sheets dynamically.

Let me know if things are unclear and I'll try to explain it better.
 
Upvote 0
I tried the code on a copy of the worksheet and it's giving me the "wrong number of arguments or invalid property assignment" on
Rich (BB code): 
If InStr(arr(x, 3), "XL_") + InStr(arr(x, 3), "PM_") Then arr(x, y) = MySUMPRODUCT(Sheets(CStr(arr(x, 3)), CStr(arr(x, 3)), CStr(arr(1, y))))
- I think it's due to MySUMPRODUCT(Sheets...


 
Upvote 0
This works on your mock file file:
Code: 
Sub Macro1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant

    With Sheets("Tracker")
        x = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(1, 2).Resize(x, 52).Value
        
        For x = LBound(arr, 1) + 4 To UBound(arr, 1)
            On Error Resume Next
            For y = LBound(arr, 2) + 2 To UBound(arr, 2)
                arr(x, y) = MySUMPRODUCT(Sheets(arr(2, y)), CDate(arr(4, y)), CStr(arr(x, 1)))
            Next y
            On Error GoTo 0
        Next x

        .Cells(1, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    Erase arr

End Sub

Private Function MySUMPRODUCT(ByRef wks As Worksheet, ByRef Dte As Date, ByRef strTask As String) As Double

    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    MySUMPRODUCT = 0
    
    With wks
        arr = .Cells(6, 4).Resize(97, 62).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            For y = LBound(arr, 2) + 2 To UBound(arr, 2)
                On Error Resume Next
                MySUMPRODUCT = MySUMPRODUCT + (--(CStr(arr(x, y)) = strTask) * --(CDate(arr(x, 1)) = Dte))
                On Error GoTo 0
            Next y
        Next x
    End With
    Erase arr
    
    MySUMPRODUCT = MySUMPRODUCT * 0.125
    
End Function
 
Last edited:
Upvote 0
I've just tried it and got a Subscript Out of Range error at line
Code: 
 arr(x, y) = MySUMPRODUCT(Sheets(arr(2, y)), CDate(arr(4, y)), CStr(arr(x, 1)))
 
Upvote 0
Re tested, this works on the mock up file with no errors and the values returned match:
Code: 
Sub Macro1()


    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant


    With Sheets("Tracker")
        x = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(1, 2).Resize(x, 52).Value
        
        For x = LBound(arr, 1) + 4 To UBound(arr, 1)
            On Error Resume Next
            For y = LBound(arr, 2) + 2 To UBound(arr, 2)
                arr(x, y) = MySUMPRODUCT(Sheets(arr(2, y)), CDate(arr(4, y)), CStr(arr(x, 1)))
            Next y
            On Error GoTo 0
        Next x


        .Cells(1, 2).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    Erase arr


End Sub


Private Function MySUMPRODUCT(ByRef wks As Worksheet, ByRef Dte As Date, ByRef strTask As String) As Double


    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    MySUMPRODUCT = 0
    
    With wks
        arr = .Cells(6, 4).Resize(97, 62).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            On Error Resume Next
            For y = LBound(arr, 2) + 2 To UBound(arr, 2)
                MySUMPRODUCT = MySUMPRODUCT + (--(CStr(arr(x, y)) = strTask) * --(CDate(arr(x, 1)) = Dte))
            Next y
            On Error GoTo 0
        Next x
    End With
    Erase arr
    
    MySUMPRODUCT = MySUMPRODUCT * 0.125
    
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
912
Legacy 352679
L
V
  • Solved
Formula to calculate automatically progressive average
Replies
5
Views
499
etaf
etaf
M
  • Locked
  • Question Question
Start and End
Replies
1
Views
539
Peter_SSs
Peter_SSs
P
  • Solved
Transpose with dates problem - from the dd/mm/yy to mm/dd/yyyy
Replies
4
Views
589
Alex Blakenburg
A
Rob_010101
  • Question Question
Weekly meeting tracker
Replies
6
Views
365
JerrExcel
JerrExcel

Forum statistics

Threads
1,223,907
Messages
6,175,301
Members
452,633
Latest member
DougMo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top