Grouping a VBA Array

Option Explicit

Public Sub Main()

'Get list of unique rows

Dim i As Long, j As Long, k As Long

Dim wb As Workbook
Dim ws As Worksheet

Dim arrTblData
Dim arrUniquePrimary As Variant
Dim arrUniqueSecondary As Variant

Dim arrIntGroupColumns() As Variant
Dim intSumColumn As Integer

Dim boolColumnMatch As Boolean
Dim boolRowMatch As Boolean
Dim intSumRowNumber As Integer

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
arrTblData = ws.ListObjects("tblData").DataBodyRange

'Set column numbers for grouping here
    arrIntGroupColumns = Array(1, 2, 3, 4)

'Set column to be summed here
    intSumColumn = 6

'Set grouping array size.  Number of columns is + 2 as the GroupColumns is 0 based array and we need one extra column for sum
    ReDim arrUniquePrimary(1 To 1, 1 To UBound(arrIntGroupColumns) + 2)
    ReDim arrUniqueSecondary(1 To 1, 1 To UBound(arrIntGroupColumns) + 2)

'Write first row to unique list
    WriteNewRowToUniqueArray arrIntGroupColumns, arrUniquePrimary, arrTblData, intSumColumn, 1, 1

'Loop Data Table, skip first row as it's been checked already
    For i = 2 To UBound(arrTblData, 1)
        boolColumnMatch = False 'reset columnMatch flag
        
        'Loop unique list
            For j = 1 To UBound(arrUniquePrimary, 1)
                
                'For each row in unique list check if each column matches against the data table row/column.
                'If it matches return true, else false.  Any unmatching column would indicate that this is a unique row
                    boolRowMatch = True
                    For k = 0 To UBound(arrIntGroupColumns)
                        boolColumnMatch = IIf(arrTblData(i, arrIntGroupColumns(k)) = arrUniquePrimary(j, k + 1), True, False)
                        If boolColumnMatch = False Then boolRowMatch = False
                    Next k
                
                'If matching row found exit loop, goto sum values
                    If boolRowMatch = True Then
                        intSumRowNumber = j
                        GoTo RowMatch
                    End If
                
            Next j
        
        'If Column Match is False that means row is unique
NoRowMatch:
            If boolRowMatch = False Then
                
                'Transfer primary to secondary for redim'ing
                    UniqueArrayRedim arrUniquePrimary, arrUniqueSecondary, arrIntGroupColumns
                    
                'Write current data table row to primary unique
                    WriteNewRowToUniqueArray arrIntGroupColumns, arrUniquePrimary, arrTblData, intSumColumn, i, UBound(arrUniquePrimary)
            End If
            
RowMatch:
        If boolRowMatch = True Then arrUniquePrimary(intSumRowNumber, UBound(arrUniquePrimary, 2)) = arrUniquePrimary(intSumRowNumber, UBound(arrUniquePrimary, 2)) + arrTblData(i, intSumColumn)
       
    Next i

End Sub


Private Function WriteNewRowToUniqueArray( _
                    ByVal arrIntGroupColumns As Variant, _
                    ByRef arrUniquePrimary As Variant, _
                    ByVal arrTblData As Variant, _
                    ByVal intSumColumn As Integer, _
                    ByVal intTblDataRow As Integer, _
                    ByVal intArrUniqueRow As Integer)

Dim i As Long

For i = 0 To UBound(arrIntGroupColumns)
    arrUniquePrimary(intArrUniqueRow, arrIntGroupColumns(i)) = arrTblData(intTblDataRow, arrIntGroupColumns(i))
Next

arrUniquePrimary(intArrUniqueRow, UBound(arrUniquePrimary, 2)) = arrTblData(intTblDataRow, intSumColumn)


End Function


Private Function UniqueArrayRedim( _
    ByRef arrUniquePrimary As Variant, _
    ByRef arrUniqueSecondary As Variant, _
    ByVal arrIntGroupColumns As Variant) _

 Dim i As Long, j As Long, k As Long

 arrUniqueSecondary = arrUniquePrimary
 ReDim arrUniquePrimary(1 To UBound(arrUniqueSecondary) + 1, 1 To UBound(arrIntGroupColumns) + 2)
 For j = 1 To UBound(arrUniqueSecondary, 1)
     For k = 1 To UBound(arrUniqueSecondary, 2)
         arrUniquePrimary(j, k) = arrUniqueSecondary(j, k)
     Next k
 Next j
 ReDim arrUniqueSecondary(1 To UBound(arrUniquePrimary), 1 To UBound(arrIntGroupColumns) + 2)

End Function