Using Consolidate function with an array of Ranges

Question

I am currently trying to make a system where a user can select some checkboxes that refer to tables and get a consolidated table of the ones that were selected. So far my system generates the checkboxes, checks which ones are ticked, passes that list to another function which is supposed to read the ranges for the tables that have been selected and pass that range to a consolidate function to create the final table.

I'm having trouble getting the consolidation function to work. From what I gather the .Consolidation function requires an array of ranges in string form to work, but no matter how I try to pass the ranges I can't seem to get the function to work for me

Below is the code that generates the array, while also creating a combined table on another worksheet so I could make sure that it is actually running through. The combined table is made without any trouble.

Function rangesfromtables(workinglist() As Variant) As Variant
    Dim tbl As ListObject
    Dim sht As Worksheet
    Dim workingrange As Range
    Dim workingarray() As Variant
    Dim item As Variant
    Dim loopcount As Integer
    Dim destinationsheet As Worksheet
    Dim endrow As Long
    Dim numrows As Long
    Set destinationsheet = ThisWorkbook.Worksheets("WorkingSheet")
    destinationsheet.Cells.Clear
    loopcount = 0
    endrow = 1
    For Each item In workinglist
    'Loop through each sheet and table in the workbook
        For Each sht In ThisWorkbook.Worksheets
            For Each tbl In sht.ListObjects
                If StrComp(item, tbl.name, vbTextCompare) = 0 Then
                    If loopcount = 0 Then
                        Set workingrange = tbl.Range
                        ReDim workingarray(0)
                        workingarray(UBound(workingarray)) = sht.name & tbl.Range.Address(ReferenceStyle:=xlR1C1)
                        loopcount = loopcount + 1
                    Else
                        Set workingrange = tbl.DataBodyRange
                        ReDim Preserve workingarray(UBound(workingarray) + 1)
                        workingarray(UBound(workingarray)) = sht.name & tbl.Range.Address(ReferenceStyle:=xlR1C1)
                    End If
                    numrows = workingrange.Rows.Count 'Below code copies table data to separate worksheet for checking
                    workingrange.Copy
                    destinationsheet.Range("A" & endrow).PasteSpecial Paste:=xlPasteValues

                    endrow = endrow + numrows
                End If
            Next tbl
        Next sht
    Next item
    
    rangesfromtables = workingarray
    
End Function

This is the function that is supposed to consolidate the tables

Sub consolidatetable(workingrange() As Variant)
    Dim destinationsheet As Worksheet

        
    Set destinationsheet = ThisWorkbook.Worksheets("Main Sheet")
    
    destinationsheet.Cells.Clear

    destinationsheet.Range("A6").Consolidate _
        Sources:=workingrange, _
        Function:=x1Sum, _
        TopRow:=True, _
        LeftColumn:=True, _
        CreateLinks:=False

 End Sub

Whenever I run the code I get the error 1004 Consolidate method of Range class failed

I have a feeling that my problem is putting the ranges of the tables into the array incorrectly, but I have tried many different ways and I can't seem to do it. I've tried having a string array instead of variant, tried passing the ranges without modifying them, at the moment I'm attempting to turn the range into a string, but I don't know if I'm doing it correctly.

Any help would be appreciated.

A small update, even when I put a range in manually, I still get the error, but I feel like I'm using the function correctly according to the documentation

Sub consolidatetable(workingrange() As Variant)
    Dim destinationsheet As Worksheet

        
    Set destinationsheet = ThisWorkbook.Worksheets("Main Sheet")
    
    destinationsheet.Cells.Clear

    destinationsheet.Range("A6").Consolidate _
        Sources:="WorkingSheet!A1:J23", _
        Function:=x1Sum, TopRow:=True, LeftColumn:=True, CreateLinks:=False

 End Sub

Answer 1

Thanks for the help guys, sorry about my slow response. In the end I gave up on the built in consolidate function and just made my own. It loops through the combined table that I made just to check that my loop function was working, checks if the first column matches and if it does it sums the 8th columnn, then deletes the original row. The tables I were working with all had the same number of columns, but could be different numbers of rows, some worksheets had multiple tables on them, and no matter how I tried to use the consolidate function it just didn't seem to want to work the same as when you use the Consolidation button under Data in excel.

You can find all of my code below, I have been a bit lazy in commenting out the superfluous code but since I got it working I walked away from it a bit without tidying it up. So if you are ever looking for a way to create a checkbox list for each table you have in a workbook, then combine certain tables and consolidate them, this may help you. The code is a bit of a mess and I'm sure there are more efficient ways of doing what I have done but this way worked for me. I did copy some code from various places, and where I did I tried to leave the comments in.

Private Sub populatelist_Click()
    'Loops through all Tables in workbook
    Call LoopThroughAllTablesinWorkbook
    numofcheckboxes = 0 'reset number of check boxes for rerun
    
End Sub
Private Sub createlist_Click()
    Dim checkedlist() As Variant
    Dim lastrowoftable As Long
    
    
    checkedlist = examinecheckboxes()
    lastrowoftable = rangesfromtables(checkedlist)
    Call consolidatetable(lastrowoftable)
    'MsgBox Join(consolidationrange, vbCrLf)
    
End Sub

Sub LoopThroughAllTablesinWorkbook()

'PURPOSE: Loop through and apply a change to all Tables in the Excel Workbook
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim tbl As ListObject
Dim sht As Worksheet
Dim chkboxleft As Integer
Dim chkboxtop As Integer

chkboxleft = 10
chkboxtop = 20

'Loop through each sheet and table in the workbook
  For Each sht In ThisWorkbook.Worksheets
    For Each tbl In sht.ListObjects
    
    Call createcheckbox(tbl.name, chkboxleft, chkboxtop)
    'move next checkbox down 15pts
    chkboxtop = chkboxtop + 15
    numofcheckboxes = numofcheckboxes + 1
    

        
    Next tbl
  Next sht

End Sub

Sub createcheckbox(name As String, left As Integer, top As Integer)

    'Add Dynamic Checkbox and assign it to object 'Cbx'
    Set Cbx = UserForm1.Controls.Add("Forms.CheckBox.1")
    
    'Assign Checkbox Name
    Cbx.Caption = name
    
    'Checkbox Position
    Cbx.left = left
    Cbx.top = top
    Cbx.Width = 150
    
End Sub
Function examinecheckboxes() As Variant

    'Checks if checkboxes are selected and if they are adds the names of the tables to the array
    Dim checked As Integer
    Dim ctrl As Object
    Dim workingarray() As Variant
    checked = 0
    For Each ctrl In UserForm1.Controls
        
        If TypeName(ctrl) = "CheckBox" Then
            If ctrl.Value = True Then
            
                If checked = 0 Then
                ReDim workingarray(0)
                workingarray(UBound(workingarray)) = ctrl.Caption
                Else
                ReDim Preserve workingarray(UBound(workingarray) + 1)
                workingarray(UBound(workingarray)) = ctrl.Caption
                End If
                
            checked = checked + 1
            
            End If
        End If
    Next ctrl

    examinecheckboxes = workingarray
End Function
Function rangesfromtables(workinglist() As Variant) As Long
    Dim tbl As ListObject
    Dim sht As Worksheet
    Dim workingrange As Range
    Dim workingarray() As Variant
    Dim item As Variant
    Dim loopcount As Integer
    Dim destinationsheet As Worksheet
    Dim endrow As Long
    Dim numrows As Long
    Set destinationsheet = ThisWorkbook.Worksheets("WorkingSheet")
    destinationsheet.Cells.Clear 'Clear Workingsheet so unneeded data isnt included
    loopcount = 0
    endrow = 1
    For Each item In workinglist
    'Loop through each sheet and table in the workbook
        For Each sht In ThisWorkbook.Worksheets
            For Each tbl In sht.ListObjects
                If StrComp(item, tbl.name, vbTextCompare) = 0 Then
                    If loopcount = 0 Then
                        Set workingrange = tbl.Range
                        ReDim workingarray(0)
                        workingarray(UBound(workingarray)) = sht.name & "!" & tbl.Range.Address(ReferenceStyle:=xlR1C1) 'format sheet name and table range for consolidate function to work
                        loopcount = loopcount + 1
                    Else
                        Set workingrange = tbl.DataBodyRange
                        ReDim Preserve workingarray(UBound(workingarray) + 1)
                        workingarray(UBound(workingarray)) = sht.name & "!" & tbl.Range.Address(ReferenceStyle:=xlR1C1)
                    End If
                    numrows = workingrange.Rows.Count 'Below code copies table data to separate worksheet for checking
                    workingrange.Copy
                    destinationsheet.Range("A" & endrow).PasteSpecial Paste:=xlPasteValues

                    endrow = endrow + numrows
                End If
            Next tbl
        Next sht
    Next item
    
    rangesfromtables = endrow
    
End Function
Sub consolidatetable(lastrow As Long)
    Dim destinationsheet As Worksheet
    Dim sourcesheet As Worksheet

        
    Set destinationsheet = ThisWorkbook.Worksheets("Main Sheet")
    Set sourcesheet = ThisWorkbook.Worksheets("WorkingSheet")
    
    destinationsheet.Cells.Clear
    

    
    For x = lastrow To 2 Step -1
    For y = 2 To lastrow
        If sourcesheet.Cells(x, 1).Value = sourcesheet.Cells(y, 1).Value And x > y Then
            sourcesheet.Cells(y, 8).Value = sourcesheet.Cells(x, 8).Value + sourcesheet.Cells(y, 8).Value
            sourcesheet.Rows(x).EntireRow.Delete
            Exit For
        End If
    Next y
Next x

    sourcesheet.Range("A1:A" & lastrow).Copy destinationsheet.Range("A7:A" & (lastrow + 7))
    sourcesheet.Range("H1:I" & lastrow).Copy destinationsheet.Range("B7:C" & (lastrow + 7))

'    destinationsheet.Range("A6").Consolidate _
'       Sources:=Array("ESK12!R5C1:R15C9", "ESK12!R19C1:R25C9"), _
'       Function:=x1Sum, TopRow:=True, LeftColumn:=False, CreateLinks:=False

 End Sub
`

Answer 2

Here's a simple example of a use of the Consolidate method that works for me. Hopefully, this will work on your side and help you see what isn't working, but if it doesn't we'll know that it's not your code that is at fault.

First add the following to Sheet1:

And the following in Sheet2:

Then make sure that Sheet3 is empty and run the following (from a module in the same workbook):

Sub ConsolidateTest()

    Dim rng As Range
    Set rng = ThisWorkbook.Sheets("Sheet3").Cells(1, 1)
       
    rng.Consolidate _
        Sources:=Array("Sheet1!R1C1:R3C3", "Sheet2!R1C1:R3C3"), _
        Function:=-4157, _
        TopRow:=True, _
        LeftColumn:=True, _
        CreateLinks:=False

End Sub

You should then get the following result: