Sum column values based on condition

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