Sum array (or something) based on multiple criteria

Hi,

Have a big problem - don't know If its possible to solve it with VBA. If the socialsec, date, fruit is same then save it into a temp or something sum quantity and print out as 1 line else different rows.

Have a sheet with following data:

SocialSec Date Fruit Quantity
12345 2015-02-02 Apple 5
12345 2015-02-02 Apple 3
11223 2015-02-01 Banana 1
11223 2015-02-01 Pear 1

Printout in Sheet2:

SocialSec Date Fruit Quantity
12345 2015-02-02 Apple 8
11223 2015-02-01 Banana 1
11223 2015-02-01 Pear 1

Is this possible to solve? Best way to solve it thru an array, or? Feels impossible with VBA.

Thanks for help!

Thanks for the tips but I need to solve it with VBA - this will be a part of my script.

Originally Posted by zbor

Use Pivot table

TEST WORKBOOK.xlsxThank you sir.
Will attach my workbook - sorry for the bad choice of color.

Originally Posted by zbor

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and use the paperclip icon to open the upload window.

View Pic

LoL! I'm sorry for being unclear.
Criteras: SocialSec, Date and fruit .

Thnx in advanced!

Originally Posted by zbor

don't be sorry for color but for example

Elaborate logic from:

112233	4.2.2015	Strawberry	10
112234	5.2.2015	Strawberry	11
112235	5.2.2015	Strawberry	12

to:

112233	4.2.2015	Strawberry	10
112233	4.2.2015	Strawberry	23

Is SocialSec criteria?
is Date criteria?
Fruit is, I got that.

Hi sir,

My after sheet its not wrong. Its two different dates on all 3 lines of the strawberry fruit. I will try this and see how it works - will reconnect to you

Originally Posted by zbor

I assume that but in that case your After sheet is wrong.
Here, try this;

Sub combine()
Dim LR As Long
On Error Resume Next

Application.ScreenUpdating = False
LR = Range("A65536").End(xlUp).Row
For i = LR To 1 Step -1
    If Range("A1").Offset(i, 0) <> "" Then

    Range("A1").Offset(i, 3) = WorksheetFunction.SumIfs(Range("A2:A" & LR).Offset(, 3), Range("A2:A" & LR).Offset(, 0), Range("A1").Offset(i, 0), Range("A2:A" & LR).Offset(, 1), Range("A1").Offset(i, 1), Range("A2:A" & LR).Offset(, 2), Range("A1").Offset(i, 2))
    
    If WorksheetFunction.CountIfs(Range("A" & i + 1 & ":A" & LR).Offset(, 0), Range("A1").Offset(i, 0), Range("A" & i + 1 & ":A" & LR).Offset(, 1), Range("A1").Offset(i, 1), Range("A" & i + 1 & ":A" & LR).Offset(, 2), Range("A1").Offset(i, 2)) > 1 Then
        Range("A1").Offset(i).EntireRow.Delete
    End If
    End If
Application.ScreenUpdating = True
Next i
    
    
End Sub

I have try to run the script but nothing happens? I placed an message box at the end and its running all the way but no printlines in sheet2? Have I forget something?
Possible to get some comments in script? Try to read it but feels like the whole script is only based on column A wich is only 1 of 3 criteras or am I lost again?

Originally Posted by zbor

I assume that but in that case your After sheet is wrong.
Here, try this;

Sub combine()
Dim LR As Long
On Error Resume Next

Application.ScreenUpdating = False
LR = Range("A65536").End(xlUp).Row
For i = LR To 1 Step -1
    If Range("A1").Offset(i, 0) <> "" Then

    Range("A1").Offset(i, 3) = WorksheetFunction.SumIfs(Range("A2:A" & LR).Offset(, 3), Range("A2:A" & LR).Offset(, 0), Range("A1").Offset(i, 0), Range("A2:A" & LR).Offset(, 1), Range("A1").Offset(i, 1), Range("A2:A" & LR).Offset(, 2), Range("A1").Offset(i, 2))
    
    If WorksheetFunction.CountIfs(Range("A" & i + 1 & ":A" & LR).Offset(, 0), Range("A1").Offset(i, 0), Range("A" & i + 1 & ":A" & LR).Offset(, 1), Range("A1").Offset(i, 1), Range("A" & i + 1 & ":A" & LR).Offset(, 2), Range("A1").Offset(i, 2)) > 1 Then
        Range("A1").Offset(i).EntireRow.Delete
    End If
    End If
Application.ScreenUpdating = True
Next i
    
    
End Sub

Sir, thank you so much!!! It works perfectly!!!!! So glad!
Possible to get som comments in the script so I can add/remove more criterias?

thank you!

Originally Posted by zbor

I assume that but in that case your After sheet is wrong.
Here, try this;

Sub combine()
Dim LR As Long
On Error Resume Next

Application.ScreenUpdating = False
LR = Range("A65536").End(xlUp).Row
For i = LR To 1 Step -1
    If Range("A1").Offset(i, 0) <> "" Then

    Range("A1").Offset(i, 3) = WorksheetFunction.SumIfs(Range("A2:A" & LR).Offset(, 3), Range("A2:A" & LR).Offset(, 0), Range("A1").Offset(i, 0), Range("A2:A" & LR).Offset(, 1), Range("A1").Offset(i, 1), Range("A2:A" & LR).Offset(, 2), Range("A1").Offset(i, 2))
    
    If WorksheetFunction.CountIfs(Range("A" & i + 1 & ":A" & LR).Offset(, 0), Range("A1").Offset(i, 0), Range("A" & i + 1 & ":A" & LR).Offset(, 1), Range("A1").Offset(i, 1), Range("A" & i + 1 & ":A" & LR).Offset(, 2), Range("A1").Offset(i, 2)) > 1 Then
        Range("A1").Offset(i).EntireRow.Delete
    End If
    End If
Application.ScreenUpdating = True
Next i
    
    
End Sub