Array calculations instead of SUMPRODUCT

[aethere92]

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)

	A	B	C
1	Tasks/Date	21/08/2017	22/08/2017
2	Task_1	=SUMPRODUCT(('35'!$C$1:$E$4=$A2)*('35'!$A$1:$A$4=B$1))
3	Task_2

<tbody>
</tbody>

(week "35" sheet)

	A	B	C	D	E
1	21/08/2017	08:00		Task_1	Task_2
2	21/08/2017	09:00	Task_2	Task_1
3	22/08/2017	08:00	Task_1
4	22/08/2017	09:00	Task_2

<tbody>
</tbody>

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:

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!

 

[JackDanIce]

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?

 

[aethere92]

Hey,

The formula I'm working with is the one within the code tags:

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.

 

[JackDanIce]

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?

 

[JackDanIce]

Best guess and untested, replace all of your code with:

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.

 

[aethere92]

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

=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.

 

[aethere92]

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

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...

 

[JackDanIce]

This works on your mock file file:

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

 

[aethere92]

I've just tried it and got a Subscript Out of Range error at line

 arr(x, y) = MySUMPRODUCT(Sheets(arr(2, y)), CDate(arr(4, y)), CStr(arr(x, 1)))

 

[JackDanIce]

Re tested, this works on the mock up file with no errors and the values returned match:

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