Consulting

Results 1 to 14 of 14

Thread: VBA Sum Array Formulas

  1. #1

    VBA Sum Array Formulas

    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
    Attached Files Attached Files

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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


    Capture.JPG
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

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

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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

    Capture.JPG

    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
    Attached Files Attached Files
    Last edited by Paul_Hossler; 10-19-2020 at 09:18 AM. Reason: make sure the right attachment is loaded
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

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

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

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

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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")

    Capture.JPG




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

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

    Capture2.JPG


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

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

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

  10. #10
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Probably the spaces. You need a single quote around the WS name if there's spaces in it (I should have remembered )

     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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  11. #11
    Quote Originally Posted by Paul_Hossler View Post
    Probably the spaces. You need a single quote around the WS name if there's spaces in it (I should have remembered )

     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

  12. #12
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  13. #13
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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' ?

  14. #14
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Quote Originally Posted by snb View Post
    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.
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •