# Thread: Sum for a certain criteria

1. ## Sum for a certain criteria

Hi
I would like to sort the following table and sum cost for the three parameters

Query

 Parameter1 Parameter2 Parameter3(m) Cost 1 a 100 30 1 a 100 10 1 c 200 30 2 b 700 20 2 b 700 10 1 a 200 70 1 c 200 40
Output
 Parameter1 Parameter2 Parameter3 TotalCost 1 a 100 40 1 a 200 70 1 c 200 70 2 b 700 30

2. welcome to the forum

Parameter1, Parameter2, Parameter3(m) to the rows area and Cost to the values area.

show pt in tabular form.

"repeat item labels" for Parameter1 and Parameter2.

vbax_62884_pt.jpg

3. Hi Thanks I already put it in a pivot table but I would like to vba code it as I want to add more restrictions to the code. for instance i actually want to limit the cost to a 100. if the cost goes over 100, I want to write the same parameters on the next line
 Parameter1 Parameter2 Parameter3 cost 1 a 100 100 (reached 100, so write remainder on next line) 1 a 100 100 1 a 100 70
Thanks for the feedback. I hope to hear from you soon.

4. assuming A1:A8 of Sheet1 houses your table, below code will do what you asked for in post #1
summary table will be written to H1:K5 on the same sheet.

```Sub vbax_62884_sum_based_on_multi_crit_uniquity()

Dim scrDic As Object
Dim i As Long, rw As Long
Dim arr, dx, k

Set scrDic = CreateObject("Scripting.Dictionary")
scrDic.CompareMode = vbTextCompare

With Sheets("Sheet1")
.Cells(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Key2:=.Range("B2"), Order2:=xlAscending, _
arr = .Cells(1).CurrentRegion.Value
End With

For i = LBound(arr, 1) + 1 To UBound(arr, 1)
dx = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
If Not scrDic.Exists(dx) Then
Else
scrDic(dx) = scrDic(dx) + arr(i, 4)
End If
Next i

With Sheets("Sheet1")
.Range("H1").CurrentRegion.ClearContents

rw = 2
.Range("H1").Resize(, 4).Value = Application.Index(arr, 1, 0)
For Each k In scrDic
.Range("H" & rw).Resize(, 3) = Split(k, "|")
.Range("K" & rw) = Split(scrDic(k), "|")(0)
rw = rw + 1
Next k
End With

End Sub```
your request in post #3 is totally different and i am not sure i can follow you.

5. Originally Posted by mancubus
assuming A1:A8 of Sheet1 houses your table, below code will do what you asked for in post #1
summary table will be written to H1:K5 on the same sheet.

```Sub vbax_62884_sum_based_on_multi_crit_uniquity()

Dim scrDic As Object
Dim i As Long, rw As Long
Dim arr, dx, k

Set scrDic = CreateObject("Scripting.Dictionary")
scrDic.CompareMode = vbTextCompare

With Sheets("Sheet1")
.Cells(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Key2:=.Range("B2"), Order2:=xlAscending, _
arr = .Cells(1).CurrentRegion.Value
End With

For i = LBound(arr, 1) + 1 To UBound(arr, 1)
dx = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
If Not scrDic.Exists(dx) Then
Else
scrDic(dx) = scrDic(dx) + arr(i, 4)
End If
Next i

With Sheets("Sheet1")
.Range("H1").CurrentRegion.ClearContents

rw = 2
.Range("H1").Resize(, 4).Value = Application.Index(arr, 1, 0)
For Each k In scrDic
.Range("H" & rw).Resize(, 3) = Split(k, "|")
.Range("K" & rw) = Split(scrDic(k), "|")(0)
rw = rw + 1
Next k
End With

End Sub```
your request in post #3 is totally different and i am not sure i can follow you.

Hi Thanks a million. It works perfectly. Sorry let me elaborate further to post 3.
I have the same data as post 1. Only i added the 6th column total for you to follow. the total is the summation of the cost for parameter 1,2 and 3.
 Parameter1 Parameter2 Parameter3imension Parameter4:Cost Total 1 a 100 130 240 1 a 100 110 1 a 200 270 580 1 c 200 30 1 c 200 280 2 b 700 20 130 2 b 700 110

I would like to represent the data as:
 Parameter1 Parameter2 Parameter3 Parameter4:Cost 1 a 100 100 1 a 100 100 1 a 100 40 1 b 200 100 1 b 200 100 1 b 200 100 1 b 200 100 1 b 200 100 1 b 200 80 2 c 700 100 2 c 700 30

The cost should take the total sum and split it into 100's in each row. if 100 cannot be made it should take the balance. Please refer to the table above.
Thank you again for the speedy response

(see 2 in my signature)

input and output tables' parameters do not match.

7. Originally Posted by mancubus
(see 2 in my signature)

input and output tables' parameters do not match.
Data.xlsx

8. with the help of a small PT...

```Sub vbax_62884_distribute_sums_to_rows_based_on_threshold()

Dim pt As PivotTable
Dim i As Long, j As Long, rw As Long, dRows As Double
Dim arr
Const MaxCost As Long = 100

With Sheets("Sheet1") 'Change "Sheet1" to suit
For Each pt In .PivotTables 'clear existing PTs
pt.TableRange2.Clear
Next pt

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=.Cells(1).CurrentRegion, _
Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:=.Cells(2, 200), _
TableName:="PivotTable1", _
DefaultVersion:=xlPivotTableVersion15

Set pt = .PivotTables("PivotTable1")
End With

With pt.PivotFields("Parameter 1") 'change "Parameter 1" to column A header
.Orientation = xlRowField
.Position = 1
.Subtotals(1) = False
.RepeatLabels = True
End With
With pt.PivotFields("Parameter 2") 'change "Parameter 2" to column B header
.Orientation = xlRowField
.Position = 2
.Subtotals(1) = False
.RepeatLabels = True
End With
With pt.PivotFields("Parameter 3") 'change "Parameter 3" to column C header
.Orientation = xlRowField
.Position = 3
.Subtotals(1) = False
End With

With pt
.AddDataField pt.PivotFields("Parameter 4: Cost"), "Cost", xlSum '"Parameter 4: Cost" changed to "Cost"
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False

arr = .TableRange2.Value
.TableRange2.Clear
End With

rw = 1
With Sheets("Sheet1") 'Change "Sheet1" to suit
.Range("H1").CurrentRegion.ClearContents
.Range("H1").Resize(, 4).Value = Application.Index(arr, 1, 0)
For i = LBound(arr) + 1 To UBound(arr)
dRows = arr(i, 4) / MaxCost
If dRows <= 1 Then
rw = rw + 1
.Range("H" & rw).Resize(, 3).Value = Application.Index(arr, i, 0)
.Range("K" & rw) = arr(i, 4)
Else
For j = 1 To Int(dRows)
rw = rw + 1
.Range("H" & rw).Resize(, 3).Value = Application.Index(arr, i, 0)
.Range("K" & rw) = MaxCost
Next j
rw = rw + 1
.Range("H" & rw).Resize(, 3).Value = Application.Index(arr, i, 0)
.Range("K" & rw) = arr(i, 4) Mod MaxCost
End If
Next i
End With

End Sub```

9. Hi thanks for the code. I cannot seem to pass this error: invalid procedure or argument call for the following piece of code:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=.Cells(1).CurrentRegion, _
Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:=.Cells(2, 200), _
TableName:="PivotTable1", _
DefaultVersion:=xlPivotTableVersion15-----------------error lies in this line