Sum column values based on condition - excel

Question

I'm an intern and I've been struggling to find a solution since this monday...
I'm new to VBA and I don't clearly see how I can sum cells from a column based on some conditions..I tried multiple code but as soon as my codes didnt work I deleted them.
So what I'm trying to do is the following;
I've got a worksheet called worksheets("Amounts") in which I've got a data base.
What I've been struggling to do since this Monday :
Sum the amounts value in column Q ( "AMOUNT") Only if rows of COL A, col B, col C, col , col E, col F have equivalent cells value.
Then, I'd like to sum in col Q the amounts based on the previous condition and put the total in one single row in the place of the rows that contain common values.
Right after I'd like to delete each rows that were matching to one another to display the agregated amount with the common values. Like the following example;
My data base;
COL A
COL B
COL C
COL E
COL F
COL Q
CODE
STATUE
ATTRIBUTE
Country
Capital
AMOUNT
A1
OK
Z1
ENGLAND
LONDON
400
C1
NOK
R2
SPAIN
MADRID
50
A1
OK
Z1
ENGLAND
LONDON
300
D1
PENDING
X
CANADA
OTTAWA
10
the Output expected;
COL A
COL B
COL C
COL E
COL F
COL Q
CODE
STATUE
ATTRIBUTE
Country
Capital
AMOUNT
A1
OK
Z1
ENGLAND
LONDON
700
C1
NOK
R2
SPAIN
MADRID
50
D1
PENDING
X
CANADA
OTTAWA
10
==> So here we have only 2 rows with common value on col A, B, C, E and F. I'd like to sum the amounts of these two rows and delete these two rows to make a single one with these common values like the up-above example.
Obviously for the other rows that dont match with other rows I'd like to let them as they were.
the database in worksheets("Amount") can vary and can get more or less rows, so I will need to automatize this process.
Here is my last saved code:
Option Explicit
Sub agreg()
Dim i As Long
Dim ran1 As Range
ran1 = ThisWorkbook.Worksheets("Values").Range("A" & Worksheets("Values").Rows.Count).End(xlUp).row + 1
For Each i In ran1
If Cells(i, 1) = Range("A1", Range("A1").End(xlDown)).Value Then
cells(i,4) + range("D1",range("D1").End(xlDown)).Value
End If
Next i
End Sub ```

Answer 1

Please, test the next code:
Sub SumUnique5Cols()
Dim sh As Worksheet, lastRow As Long, arr, arrQ, rngDel As Range, i As Long, dict As Object
Set sh = Worksheets("Amounts")
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row based on A:A column
arr = sh.Range("A2:Q" & lastRow).Value2 'place the range in an array to make the code faster
Set dict = CreateObject("Scripting.Dictionary") 'set a dictionary to keep the unique keys combination value
For i = 1 To UBound(arr) 'iterate between the array elements
If Not dict.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 5) & arr(i, 6)) Then 'if the combination key does not exist:
dict.Add arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 5) & arr(i, 6), arr(i, 17) 'it is created (and take the value of Q:Q cell)
Else 'if the key aleready exists, it adds the value in the key item:
dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 5) & arr(i, 6)) = dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 5) & arr(i, 6)) + arr(i, 17)
'range of the rows to be deleted is filled in this way:
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i + 1) 'if the range does not exist, it is set (i + 1, because of iteration starting from the second row)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i + 1)) 'if it exists, a union between the previus range and the new one is created
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete 'if there are rows to be deleted, they are deleted
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row 'recalculate the last row (after rows deletion)
arr = sh.Range("A2:Q" & lastRow).Value2 'place the remained range in an array
ReDim arrQ(1 To UBound(arr), 1 To 1) 'ReDim the final array (to keep the summ) according to the remained rows
For i = 1 To UBound(arr)
arrQ(i, 1) = dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 5) & arr(i, 6)) 'put in the array the corresponind dictionary key value
Next i
sh.Range("Q2").Resize(UBound(arrQ), 1).value = arrQ 'drop the array content at once
End Sub

Answer 2

In Power Query it would be simple:
Group by those columns
Aggregate by the Sum of Amount
Power Query is available in Windows Excel 2010+ and Office 365
To use Power Query
Select some cell in your Data Table
Data => Get&Transform => from Table/Range
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm
M Code
let
//Change table name in next line to actual table name in the workbook
Source = Excel.CurrentWorkbook(){[Name="Table10"]}[Content],
//set data types
//note the columns named ColumnN which will be different with your real data
#"Changed Type" = Table.TransformColumnTypes(Source,{
{"CODE", type text},
{"STATUE", type text},
{"ATTRIBUTE", type text},
{"Column1", type any},
{"Country", type text},
{"Capital", type text},
{"Column2", type any}, {"Column3", type any}, {"Column4", type any}, {"Column5", type any}, {"Column6", type any}, {"Column7", type any}, {"Column8", type any}, {"Column9", type any}, {"Column10", type any}, {"Column11", type any},
{"Amount", Int64.Type}}),
//group by columns 1,2,3,5,6
//return Sum of the Amount Column
#"Grouped Rows" = Table.Group(#"Changed Type", {"CODE", "STATUE", "ATTRIBUTE", "Country", "Capital"},
{{"Amount", each List.Sum([Amount]), type nullable number}})
in
#"Grouped Rows"
Data
Results

Answer 3

If you want to do it with VBA I would use ADODB to group the rows
Public Sub SumGroup()
Dim connection As Object
Set connection = CreateObject("ADODB.Connection")
connection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"
Dim recordset As Object
Dim sSQL As String
sSQL = "SELECT Code, Statue, Attribute, Country, Capital, Sum(Amount) as SumAmount FROM [Database$] GROUP BY Code, Statue, Attribute, Country, Capital"
Set recordset = connection.Execute(sSQL)
Worksheets("Result").Range("A1").CopyFromRecordset recordset
recordset.Close
connection.Close
End Sub
The data should be in a sheet with the name Database. The result will be written to a sheet with the name Result. Both sheets should exist in the workbook before running the code.
A Pivottable would give you what you want without any coding nor in VBA or M