Excel, VBA - sum several rows

maxblack

maxblack

New Member
Joined
Nov 15, 2016
Messages
36
Hello Collegues,

I'm building the macro but i have a problem with one step, which I cannot solve.
I have a table as below and I need to sum all of amounts by Date IN, so at the end I need to have two lines as at the end of this table. On first sight I thought that it will be easy to do by subtotals, but this function as far as I know is only creating an additional row with sum of amounts and date... doing it manually is easy but I would like to build it in VBA, so I need to find the easiest way, which will be able to write.

ColumnAccount IDCodeNameDate OUTDate INDescriptionCodeAFBRefRefAmountCur
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8619ABC6003870.26EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD85F9ABC6003190.39EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8765ABC6004710.70EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8590ABC6003550.83EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8792ABC6004771.02EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8453ABC6002891.57EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8747ABC6004631.76EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8572ABC6003491.79EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD84C8ABC6002711.96EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD85E9ABC6003152.11EUR
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8839ABC6004892.33EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AE8ABC60091110.71EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AC8ABC60090322.99EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4A17ABC60091748.84EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AD8ABC60090752.52EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4A17ABC600915235.82EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AC8ABC600901417.25EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AE8ABC600909663.53EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AD8ABC6009051,093.99EUR
RESULT:
PARBIT800915900MD566ABCDEF21/12/201619/12/2016ABC IDNMSCRE46CD8839ABC60048914.72EUR
PARBIT800915900MD566ABCDEF21/12/201621/12/2016ABC IDNMSCRE46CE4AE8ABC6009112,545.65EUR

<tbody>
</tbody>

Thank you in advance!
Max
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
Are there multiple Account ID's Descriptions or Codes per day and do you need to track them?

If all you need are the Date and Sum, this will do it for you.

Code: 
Sub SumUnique()
    Dim i, cl As Range, Dic As Object, lastrow As Integer
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
[COLOR=#00ff00]    'for each row in the the date column[/COLOR]
    For Each cl In Sheets(1).Range("F2:F" & Range("F2").End(xlDown).Row)
[COLOR=#00ff00]        'if the date is not in the list[/COLOR]
        If Not Dic.Exists(cl.Value) Then
[COLOR=#00ff00]            'add the date and the price[/COLOR]
            Dic.Add cl.Value, cl.Offset(, 6).Value2
        Else
[COLOR=#00ff00]            'add the new value to the existing value[/COLOR]
            Dic(cl.Value) = Dic(cl.Value) + cl.Offset(, 6).Value2
        End If
    Next cl
    
[COLOR=#00ff00]    'find the last row on the sheet +3[/COLOR]
    lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row + 3
[COLOR=#00ff00]        'print titles[/COLOR]
        Cells(lastrow, 6) = "Date In"
        Cells(lastrow, 12) = "Day Total"
        lastrow = lastrow + 1
[COLOR=#00ff00]    'print a row for each key in the dictionary[/COLOR]
    For Each i In Dic
[COLOR=#00ff00]        'print the key[/COLOR]
        Cells(lastrow, 6) = i
[COLOR=#00ff00]        'print the value[/COLOR]
        Cells(lastrow, 12) = Dic(i)
        lastrow = lastrow + 1
    Next i


End Sub
 
Upvote 0
Thanks portews it looks and works perfectly and you are amazing ;).
I need this data to be sum, becouse the results will be automatically imported to the application, so no need for manual booking.
Thats why I have a few questions.

First of all I need also code (MD566) and currency to be copied, these are the most important data I need except these two, which you already done - may you tell me how to modify your code, as I have never use "objects"?

Second question is that I have already done that macro is dividing the report into sheets by codes, so I have for example sheets: MD566, MD567, MD568 etc, but your method is working so good that I think that it will be better to have the report in one sheet and create these sums in other sheet (if its possible) with only values which I need, so Code (MD566 etc), Date IN, Amount and Currency (could be next to each other). Is it possible to expand?

I hope that you understand me well. I know that I'm asking too much but as I said I have never met with objects programming and I wonder how to build it this way.

Thanks a lot!
Have a good weekend!
Max
 
Upvote 0
This method works well if you have one column that you are looking to make unique, in this case the date. If you are looking for separate lines with the date AND code AND Currency as a criteria, we'll have to do it a different way.
 
Upvote 0
This is why when I was modifying your code it wasn't working at all. I'm waiting impatiently :)
 
Upvote 0
OK, This should give you what you want.

Try this:

Code: 
Sub SumMultiCriteria()
Dim LastRow, i, j, x As Integer
Dim y As Boolean
[COLOR=#00ff00]'find the last row[/COLOR]
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
[COLOR=#00ff00]'set the first row offset[/COLOR]


x = 3
y = True


[COLOR=#00ff00]'start at row 2 to the end[/COLOR]
For i = 2 To LastRow
    
[COLOR=#00ff00]    'loop thru the summary section[/COLOR]
    For j = LastRow + 3 To LastRow + x
[COLOR=#00ff00]        'if columns C, F and M in row i match the j summary row[/COLOR]
        If Cells(i, 3) = Cells(j, 3) And Cells(i, 6) = Cells(j, 6) And Cells(i, 13) = Cells(j, 13) Then
[COLOR=#00ff00]            'add the L amount to the summary row[/COLOR]
            Cells(j, 12) = Cells(j, 12) + Cells(i, 12)
[COLOR=#00ff00]            'skip to the next row[/COLOR]
            GoTo nextrowi
        End If
[COLOR=#00ff00]    'check the next summary row[/COLOR]
    Next j
    
[COLOR=#00ff00]    'if none of the summary rows match...[/COLOR]
[COLOR=#00ff00]    'the first time[/COLOR]
    If y = True Then
[COLOR=#00ff00]        'start the summary row[/COLOR]
        x = x
[COLOR=#00ff00]        'switch this off next time thru[/COLOR]
        y = False
    Else
[COLOR=#00ff00]        'make a new summary row at the bottom[/COLOR]
        x = x + 1
    End If
[COLOR=#00ff00]    'fill in the Code, Date In, Amount and Currency[/COLOR]
    Cells(LastRow + x, 3) = Cells(i, 3)
    Cells(LastRow + x, 6) = Cells(i, 6)
    Cells(LastRow + x, 12) = Cells(i, 12)
    Cells(LastRow + x, 13) = Cells(i, 13)
[COLOR=#00ff00]    'you can put any additional columns in here,[/COLOR]
[COLOR=#00ff00]    'differences will overwrite, not start a new row.[/COLOR]


nextrowi:
Next i
End Sub
 
Upvote 0
T-H-A-N-K Y-O-U! portews its amazing and more less understable for me.
If i would like to change that summary will be saving data in next sheet for example "OK" I have to modify below lines - am I right?
Code: 
For j =  LastRow + 3 To LastRow + x
for example:
Code: 
For j = Sheets("OK").Row(1) To Sheets("OK").Row(1) + x
and
Code: 
Cells(LastRow + x, 3) = Cells(i, 3)   
Cells(LastRow + x, 6) = Cells(i, 6)  
Cells(LastRow + x, 12) = Cells(i,  12)  
Cells(LastRow + x, 13) = Cells(i, 13)

I know that if I want to have only summarized data I could after this operation select all data, offsize it for 3 more rows below and delete but I try to figure it out how to make it other way.

Thanks
 
Upvote 0
To put it on the OK sheet, changes in red. Note the additions of the periods before cells that don't have the Sheets("OK"). before it. Those are referenced by t the "With wksht" line.

Code: 
Sub SumMultiCriteria()
Dim LastRow, i, j, x As Integer
Dim wkst As Worksheet
Dim y As Boolean
[COLOR=#ff0000]'change as necessary[/COLOR]
[COLOR=#ff0000]Set wksht = Sheets("Sheet1")[/COLOR]
'find the last row
LastRow = [COLOR=#ff0000]wksht[/COLOR].Cells([COLOR=#ff0000]wksht[/COLOR].Rows.Count, "A").End(xlUp).Row


[COLOR=#ff0000]'set the starting row on the OK sheet[/COLOR]
x = [COLOR=#ff0000]2[/COLOR]
y = True


[COLOR=#ff0000]With wksht[/COLOR]
'start at row 2 to the end
For i = 2 To [COLOR=#ff0000]LastRow[/COLOR]
    
    'loop thru the summary section


For j = 2 To [COLOR=#ff0000]x[/COLOR]
        'if columns C, F and M in row i match the j summary row
        If [COLOR=#ff0000].[/COLOR]Cells(i, 3) = [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(j, 3) And [COLOR=#ff0000].[/COLOR]Cells(i, 6) =[COLOR=#ff0000] Sheets("OK").[/COLOR]Cells(j, 6) And [COLOR=#ff0000].[/COLOR]Cells(i, 13) = [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(j, 13) Then
            'add the L amount to the summary row
            [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(j, 12) = [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(j, 12) + [COLOR=#ff0000].[/COLOR]Cells(i, 12)
            'skip to the next row
            GoTo nextrowi
        End If
    'check the next summary row
    Next j
    
    'if none of the summary rows match...
    'the first time
    If y = True Then
        'start the summary row
        x = x
        'switch this off next time thru
        y = False
    Else
        'make a new summary row at the bottom
        x = x + 1
    End If
    'fill in the Code, Date In, Amount and Currency
    [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(x, 3) = [COLOR=#ff0000].[/COLOR]Cells(i, 3)
    [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(x, 6) = [COLOR=#ff0000].[/COLOR]Cells(i, 6)
    [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(x, 12) = [COLOR=#ff0000].[/COLOR]Cells(i, 12)
    [COLOR=#ff0000]Sheets("OK").[/COLOR]Cells(x, 13) = [COLOR=#ff0000].[/COLOR]Cells(i, 13)
    'you can put any additional columns in here,
    'differences will overwrite, not start a new row.




nextrowi:
Next i
End With
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
VBA to Split value across uniques found with multiple criteria
Replies
1
Views
260
melkent
M
P
  • Solved
Convert value if the date listed within the column is within the month going across the rows
Replies
3
Views
297
Fluff
Fluff
W
  • Question
Conditional Quantity sum based on duplicate values in various other columns
Replies
3
Views
323
whassan
W
S
  • Solved
VBA code to transpose rows to columns and copy data
Replies
4
Views
374
Mario_R
M
W
  • Question
Dynamic XIRR for sum of CF's with Offset
Replies
3
Views
3K
DRSteele
DRSteele

Forum statistics

Threads
1,214,606
Messages
6,120,490
Members
448,967
Latest member
visheshkotha

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top