vba - sum unique with multiple conditions - excel

Question

I would like to create a macro that will sum the unit column base by Product & DC. It will populate out the same product name, code with dc code and code without. Base on the code given I try to modify the code but fail when I added the column Sales Person in front, Date & Country, as output I want to show the data with the latest date and country and the new data in the column.
Sub Button1_Click()
' Define constants.
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A2"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Write values from Source Range to Data Array.
Dim LastRow As Long
Dim Data As Variant
With wb.Worksheets(sName).Range(sFirstCellAddress)
LastRow = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row
Data = .Resize(LastRow - .Row + 1, 8) 'modify
End With
' Write unique values from Data Array to Unique Dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim arr(1 To 2) As Variant
Dim Key As Variant
Dim cArr As Variant
Dim r As Long
For r = 1 To UBound(Data, 1)
Key = Data(r, 1)
If Not IsError(Key) Then
If Not dict.Exists(Key) Then
dict.Add Key, arr
End If
If Data(r, 2) = 0 Then
cArr = dict(Key)
cArr(2) = cArr(2) + Data(r, 3)
dict(Key) = cArr
Else
cArr = dict(Key)
cArr(1) = cArr(1) + Data(r, 3)
dict(Key) = cArr
End If
End If
Key2 = Data(r, 4)
Key3 = Data(r, 5)
Key4 = Data(r, 6)
Key5 = Data(r, 7)
Key6 = Data(r, 8)
Next r
' Write values from Unique Dictionary to Result Array.
Dim rCount As Long: rCount = dict.Count + 1
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 8) 'change from 3 to 8
Result(1, 1) = "SalesPerson"
Result(1, 2) = "Company"
Result(1, 3) = "Product"
Result(1, 4) = "Unit With DC Code"
Result(1, 5) = "Unit Without DC Code"
Result(1, 6) = "Date"
Result(1, 7) = "Country"
Result(1, 8) = "Grade"
If rCount > 1 Then
r = 1
For Each Key In dict.Keys
r = r + 1
Result(r, 1) = Key1
Result(r, 2) = Key2
Result(r, 3) = Key3
Result(r, 4) = CLng(dict(Key)(1))
Result(r, 5) = CLng(dict(Key)(2))
Result(r, 6) = Key4
Result(r, 7) = Key5
Result(r, 8) = Key6
Next Key
End If
' Write values from Result Array to Destination Range.
With wb.Worksheets(dName).Range(dFirstCellAddress).Resize(, 5)
.Resize(rCount).Value = Result
' Delete below.
'.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
End With
MsgBox ("Done")
End Sub
SalesPerson
Company
Product
DC
Unit
Date
Country
Grade
JOHN
TPP
ABC
2
12-Feb
MY
AA
JOHN
TPP
ABC
1234
4
13-Feb
MY
AA
JOHN
TPP
ABC
1234
4
14-Feb
US
AA
JOHN
PEN
DEF
5678
2
12-Feb
US
AA
JOHN
PEN
DEF
5678
2
18-Feb
MY
AA
JOHN
PKG
GHI
9012
2
16-Feb
UK
AA
I want to the output in another sheets as below:-
SalesPerson
Company
Product
Unit with DC Code
Unit Without DC Code
Date
Country
Grade
JOHN
TPP
ABC
6
2
14-Feb
US
AA
JOHN
PEN
DEF
4
18-Feb
MY
AA
JOHN
PKG
GHI
2
16-Feb
UK
AA

Answer 1

You need to build the dictionary key from the first 3 fields SalesPerson,Company,Product. I have concatenated them with tab character so they can be separated later for the results sheet.
Option Explicit
Sub Button1_Click()
' Define constants.
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A2"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Write values from Source Range to Data Array.
Dim LastRow As Long
Dim Data As Variant
With wb.Worksheets(sName).Range(sFirstCellAddress)
LastRow = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row
Data = .Resize(LastRow - .Row + 1, 8) 'modify
End With
' Write unique values from Data Array to Unique Dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim arr(3) As Variant, Key As String, tmp As Variant
Dim r As Long, i As Long
For r = 1 To UBound(Data, 1)
' composite key SalesPerson,Company,Product
Key = Data(r, 1) & vbTab & Data(r, 2) & vbTab & Data(r, 3)
If Not IsError(Key) Then
If Not dict.Exists(Key) Then
dict.Add Key, Array(0, 0, r)
End If
i = 0
If Len(Data(r, 4)) = 0 Then i = 1
' sum counts
tmp = dict(Key)
tmp(i) = tmp(i) + Data(r, 5)
tmp(2) = r ' store last row
dict(Key) = tmp
End If
Next r
' result
Dim k As Variant, wsOut As Worksheet, rngOut As Range
Set wsOut = wb.Worksheets(dName)
Set rngOut = wsOut.Range(dFirstCellAddress)
rngOut.Resize(, 8) = Array("SalesPerson", "Company", "Product", "Unit With DC Code", _
"Unit Without DC Code", "Date", "Country", "Grade")
For Each k In dict
Set rngOut = rngOut.Offset(1, 0)
tmp = Split(k, vbTab)
rngOut.Offset(0, 0) = tmp(0)
rngOut.Offset(0, 1) = tmp(1)
rngOut.Offset(0, 2) = tmp(2)
rngOut.Offset(0, 3) = dict(k)(0)
rngOut.Offset(0, 4) = dict(k)(1)
' Date Country Grade
r = dict(k)(2)
rngOut.Offset(0, 5) = Data(r, 6)
rngOut.Offset(0, 6) = Data(r, 7)
rngOut.Offset(0, 7) = Data(r, 8)
Next
MsgBox "Done", vbInformation
End Sub

Answer 2

In addition to a VBA solution (and I would probably use a dictionary with the SalesPerson as the key, and a class object containing the relevant information), I would suggest also looking at Power Query (available in Excel 2010+).
It may prove easier to maintain and modify once you get used to the language.
For the task at hand, you could start, for example, by
select a cell in the data table
Data => Get&Transform => from Table/Range
When the PQ UI opens, goto Home => Advanced Editor
Note the name of the table in line 2 of the code you see.
Then replace that code with the M-Code below, changing the table name to what your actual table name is.
You should be able to figure out what is happening by going through the applied steps window in the UI, and also reading the annotations.
To update, you merely Refresh the query. And you could program a button to do that.
M Code edited and shortened
let
//change table name in next line to the real table name in your workbook
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,
{{"SalesPerson", type text}, {"Company", type text}, {"Product", type text}, {"DC", Int64.Type},
{"Unit", Int64.Type}, {"Date", type date}, {"Country", type text}, {"Grade", type text}}),
//Group by SalesPerson, Company and Product
//Extract the needed information
#"Grouped Rows" = Table.Group(#"Changed Type", {"SalesPerson", "Company", "Product"},
{
{"Unit with DC Code",(t) => List.Sum(Table.Column(Table.SelectRows(t, each [DC] <> null),"Unit")), Int64.Type},
{"Unit without DC Code", (t) => List.Sum(Table.Column(Table.SelectRows(t, each [DC] = null),"Unit")),Int64.Type},
{"Date", each List.Max([Date]), type nullable date},
{"Country", (t)=> Table.Column(Table.SelectRows(t, each [Date] = List.Max(Table.Column(t,"Date"))),"Country"){0},type text},
{"Grade", (t)=> Table.Column(Table.SelectRows(t, each [Date] = List.Max(Table.Column(t,"Date"))),"Grade"){0}, type text}
})
in
#"Grouped Rows"