VBA Sum Array Formulas

[annonymous33]

Hello Guy/Gals,

I hope we are all safe from Covid.


I lurk here a lot, but I am still trying to find my feet with VBA.


I am able to sum, but only with one (1) column of data. I want to move into array VBA. I've attached an example of array i want to put into VBA.

Using the index match match has proved to be somewhat troublesome and it would just be easier to use a sum array. Ive read loads of posts saying its not possible, but surely it is.

Thanks in advance for your help

Mark

[Paul_Hossler]

Don't know -- didn't seem that hard

You just have to put the array formula into each cell separately in C4:BJ9 so you end up with 360 copies of the array formula


27325

[annonymous33]

Thanks for your response Paul, but I am looking for the VBA equivalent. I do a lot of harvesting in this format, and using Arrays in native excel slows my computer.

Mark

[Paul_Hossler]

OK then, try this. SumArray() returns a variant array

For testing, the yellow is worksheet formulas and the green is the VBA equivalent

You can probably pretty this up

27328



Option Explicit


Sub test()
Dim v As Variant

With Worksheets("inputs")
v = SumArray(.Range("$B$4:$G$63"), .Range("$A$4:$A$63"), .Range("$B$3:$G$3"), _
Worksheets("Summary").Range("C1"), Worksheets("Summary").Range("A4"))
End With

Worksheets("Summary").Range("C14:BJ19").Value = v


End Sub






Function SumArray(inInput As Range, inCols As Range, inRows As Range, sumColValue As Range, sumRowValue) As Variant
Dim vOut As Variant
Dim addrInput As String, addrCol As String, addrRow As String, addrColValue As String, addrRowValue As String
Dim sFormula As String
Dim r As Long, c As Long

addrInput = inInput.Parent.Name & "!" & inInput.Address(True, True)
addrCol = inCols.Parent.Name & "!" & inCols.Columns(1).Address(True, True)
addrRow = inRows.Parent.Name & "!" & inRows.Rows(1).Address(True, True)

ReDim v(1 To inRows.Columns.Count, 1 To inCols.Rows.Count)


For r = LBound(v, 1) To UBound(v, 1)
For c = LBound(v, 2) To UBound(v, 2)
addrColValue = sumColValue.Parent.Name & "!" & sumColValue.Offset(0, c - 1).Address(True, False)
addrRowValue = sumRowValue.Parent.Name & "!" & sumRowValue.Offset(r - 1, 0).Address(False, True)

sFormula = "=SUM((" & addrInput & ")*(" & addrCol & "=" & addrColValue & ")*(" & addrRow & "=" & addrRowValue & "))"


v(r, c) = Application.Evaluate(sFormula)
Next c
Next r


SumArray = v
End Function

[annonymous33]

Thanks, it works a treat but i cant expand it, and cant get it working outside that one spreadsheet, and ive been at it for about 5 hours now

Guess its in the too hard pile

[annonymous33]

Does anyone know of any more readable examples? I think the function that renders the code useless outside of that sheet. Something to do with the Lower and upperbounds.

[annonymous33]

Paul, Thanks for your help. Based on that code, is it the case the inputs tab can be changed to anything, as long as there is no space?

[Paul_Hossler]

You should be able to change the function call to almost any ranges, so if the Data (not counting row and column headers) is M x N, the function output is a N x M variant array arranged by summing the Data by Row value and Column Value




Function SumArray(inInput As Range, inCols As Range, inRows As Range, sumColValue As Range, sumRowValue) As Variant


InInput = the data to be 'filtered' --Input!Range("$B$4:$G$63")

inCols = one column that identifies the output row value -- Range("$A$4:$A$63")

inrows = one row that identifies the output column value -- Range("$B$3:$G$3")

27331




sumColValue = starting cell for the output columns to match inCols value

sumRowValue = starting cell for the output columns to match inRows value

27332


This approach just automates the worksheet formula to Sum your apriori data and colors. But IMHO it's limited since you need the Dates and Colors in advance in order to match them for summing on the Summary sheet, and the call can be finicky

ITWM, I'd take the M x N data, make a pivot table friendly list on a temp worksheet, make a PT on another temp worksheet, and return the PT.TableRange2 in the function

If you're interested, I can work up an example

[annonymous33]

Thanks a lot for your help mate. Appreciated.

I managed to get it working by changing the tab names to not include any spaces. Should that have made a difference?

Again, really appreciate your help.

[Paul_Hossler]

Probably the spaces. You need a single quote around the WS name if there's spaces in it (I should have remembered :banghead: )



addrInput = "'" & inInput.Parent.Name & "'!" & inInput.Address(True, True)

Here's a pivot table approach in case you're interested



Option Explicit


Sub test2()
Dim v As Variant

v = SumArray2(Worksheets("Inputs").Cells(1, 1).CurrentRegion)

'puts array into the ws to check
Worksheets("Summary").Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v


End Sub




Function SumArray2(inInput As Range) As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, wsIn As Worksheet
Dim rIn As Range
Dim r As Long, c As Long, o As Long

'remove old sheet just in case
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp1").Delete
Worksheets("temp2").Delete
Application.DisplayAlerts = False

'add 2 temp sheets
Worksheets.Add
Set ws1 = ActiveSheet
ws1.Name = "temp1"
Worksheets.Add
Set ws2 = ActiveSheet
ws2.Name = "temp2"

'prep input data
Set rIn = inInput.CurrentRegion
Set wsIn = rIn.Parent

'make list for pivot table
o = 1
With ws1
.Cells(o, 1).Value = "Date"
.Cells(o, 2).Value = "Color"
.Cells(o, 3).Value = "Value"
o = o + 1

For r = 2 To rIn.Rows.Count
For c = 2 To rIn.Columns.Count
If rIn.Cells(r, c).Value > 0 Then
.Cells(o, 1).Value = rIn.Rows(r).EntireRow.Cells(1).Value
.Cells(o, 2).Value = rIn.Columns(c).EntireColumn.Cells(1).Value
.Cells(o, 3).Value = rIn.Cells(r, c).Value
o = o + 1
End If
Next c
Next r
End With

'make pivot table
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ws1.Cells(1, 1).CurrentRegion, Version:=6). _
CreatePivotTable TableDestination:=ws2.Cells(1, 1), TableName:="PivotTable1", DefaultVersion:=6

With ws2.PivotTables("PivotTable1")
.ColumnGrand = False
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = False
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlCompactRow
.CompactLayoutRowHeader = "Color"
.CompactLayoutColumnHeader = "Date"

With .PivotFields("Color")
.Orientation = xlRowField
.Position = 1
End With

With .PivotFields("Date")
.Orientation = xlColumnField
.Position = 1
End With

.AddDataField ActiveSheet.PivotTables("PivotTable1").PivotFields("Value"), "Sum of Value", xlSum

.PivotFields("Years").Orientation = xlHidden
.PivotFields("Quarters").Orientation = xlHidden
End With


'return PT, skipping first row
With ws2.PivotTables("PivotTable1").TableRange1
SumArray2 = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
End With

'remove temp sheets
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp1").Delete
Worksheets("temp2").Delete
Application.DisplayAlerts = False




End Function

[annonymous33]

Probably the spaces. You need a single quote around the WS name if there's spaces in it (I should have remembered :banghead: )



addrInput = "'" & inInput.Parent.Name & "'!" & inInput.Address(True, True)

Here's a pivot table approach in case you're interested



Option Explicit


Sub test2()
Dim v As Variant

v = SumArray2(Worksheets("Inputs").Cells(1, 1).CurrentRegion)

'puts array into the ws to check
Worksheets("Summary").Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v


End Sub




Function SumArray2(inInput As Range) As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, wsIn As Worksheet
Dim rIn As Range
Dim r As Long, c As Long, o As Long

'remove old sheet just in case
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp1").Delete
Worksheets("temp2").Delete
Application.DisplayAlerts = False

'add 2 temp sheets
Worksheets.Add
Set ws1 = ActiveSheet
ws1.Name = "temp1"
Worksheets.Add
Set ws2 = ActiveSheet
ws2.Name = "temp2"

'prep input data
Set rIn = inInput.CurrentRegion
Set wsIn = rIn.Parent

'make list for pivot table
o = 1
With ws1
.Cells(o, 1).Value = "Date"
.Cells(o, 2).Value = "Color"
.Cells(o, 3).Value = "Value"
o = o + 1

For r = 2 To rIn.Rows.Count
For c = 2 To rIn.Columns.Count
If rIn.Cells(r, c).Value > 0 Then
.Cells(o, 1).Value = rIn.Rows(r).EntireRow.Cells(1).Value
.Cells(o, 2).Value = rIn.Columns(c).EntireColumn.Cells(1).Value
.Cells(o, 3).Value = rIn.Cells(r, c).Value
o = o + 1
End If
Next c
Next r
End With

'make pivot table
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ws1.Cells(1, 1).CurrentRegion, Version:=6). _
CreatePivotTable TableDestination:=ws2.Cells(1, 1), TableName:="PivotTable1", DefaultVersion:=6

With ws2.PivotTables("PivotTable1")
.ColumnGrand = False
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = False
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlCompactRow
.CompactLayoutRowHeader = "Color"
.CompactLayoutColumnHeader = "Date"

With .PivotFields("Color")
.Orientation = xlRowField
.Position = 1
End With

With .PivotFields("Date")
.Orientation = xlColumnField
.Position = 1
End With

.AddDataField ActiveSheet.PivotTables("PivotTable1").PivotFields("Value"), "Sum of Value", xlSum

.PivotFields("Years").Orientation = xlHidden
.PivotFields("Quarters").Orientation = xlHidden
End With


'return PT, skipping first row
With ws2.PivotTables("PivotTable1").TableRange1
SumArray2 = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
End With

'remove temp sheets
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp1").Delete
Worksheets("temp2").Delete
Application.DisplayAlerts = False




End Function




Thanks a lot for all of your help.

I'm new to NOT stating the W.S name but that helps a lot.

Thanks again for your help. Ill have a look at that alternative code and work my way through it. Thanks

[Paul_Hossler]

Personally, I usually try to use the PT approach.

Here's a more better cleaned up version of the PT alternative if you're interested, better comments, squashed some bugs

Feel free to ask if my comment lines were not clear





Option Explicit


Sub test4()
Dim v As Variant

v = SumArray4(Worksheets("Inputs").Cells(1, 1).CurrentRegion)

MsgBox "Array (" & LBound(v, 1) & "-" & UBound(v, 1) & ", " & LBound(v, 2) & "-" & UBound(v, 2) & ")"

'puts array into the ws to check
Worksheets("Summary").Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v


End Sub




Function SumArray4(inInput As Range) As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, wsIn As Worksheet
Dim rIn As Range
Dim r As Long, c As Long, o As Long

'remove old sheets just in case
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp1").Delete
Worksheets("temp2").Delete
Application.DisplayAlerts = True
On Error GoTo 0

'add 2 temp sheets
Worksheets.Add
Set ws1 = ActiveSheet
ws1.Name = "temp1"
Worksheets.Add
Set ws2 = ActiveSheet
ws2.Name = "temp2"

'prep input data
Set rIn = inInput.CurrentRegion
Set wsIn = rIn.Parent

'make list for pivot table
o = 1
With ws1
.Cells(o, 1).Value = "Date"
.Cells(o, 2).Value = "Color"
.Cells(o, 3).Value = "Value"
o = o + 1

For r = 2 To rIn.Rows.Count
For c = 2 To rIn.Columns.Count
If rIn.Cells(r, c).Value > 0 Then
.Cells(o, 1).Value = rIn.Rows(r).EntireRow.Cells(1).Value
.Cells(o, 2).Value = rIn.Columns(c).EntireColumn.Cells(1).Value
.Cells(o, 3).Value = rIn.Cells(r, c).Value
o = o + 1
End If
Next c
Next r

'make pivot table
.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ws1.Cells(1, 1).CurrentRegion, Version:=6). _
CreatePivotTable TableDestination:=ws2.Cells(1, 1), TableName:="PivotTable1", DefaultVersion:=6
End With

With ws2.PivotTables("PivotTable1")
.ColumnGrand = False
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = False
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlCompactRow
.CompactLayoutRowHeader = "Color"
.CompactLayoutColumnHeader = "Date"

With .PivotFields("Color")
.Orientation = xlRowField
.Position = 1
End With

With .PivotFields("Date")
.Orientation = xlColumnField
.Position = 1
End With

.AddDataField .PivotFields("Value"), "Sum of Value", xlSum

'return PT, skipping first row
SumArray4 = .TableRange1.Cells(2, 1).Resize(.TableRange1.Rows.Count - 1, .TableRange1.Columns.Count)
End With

'remove temp sheets
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("temp1").Delete
Worksheets("temp2").Delete
Application.DisplayAlerts = True

End Function

[snb]

As long as the input sheet doesn't contain any double dates this suffices:


Sub M_snb()
sn = Sheet1.Cells(1).CurrentRegion
Sheet2.Cells(20, 1).Resize(UBound(sn, 2), UBound(sn)) = Application.Transpose(sn)
Sheet2.Cells(20, 1).CurrentRegion.Sort Sheet2.Cells(20, 1), , , , , , , 1
End Sub

So, what's the 'problem' ?

[p45cal]

So, what's the 'problem' ?
One might be that transpose converts the dates to strings, and when they're pasted onto the sheet they could remain as strings (as they did here) or worse, be interpreted by a 'helpful' Excel using MDY instead of DMY in some locales.
I know, using dates as table headers doesn't work well anyway in true Excel Tables.

Anyway, attached has 2 more options without vba; a plain Power Query table and a pivot direct from a Power Query query.