PDA

View Full Version : Sum for a certain criteria



Oran
06-04-2018, 04:24 AM
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

mancubus
06-04-2018, 06:11 AM
welcome to the forum

how about a pivot table?

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.

22357

Oran
06-04-2018, 12:46 PM
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.

mancubus
06-05-2018, 07:52 AM
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, _
Header:=xlYes
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
scrDic.Add dx, arr(i, 4)
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.

Oran
06-06-2018, 12:22 PM
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, _
Header:=xlYes
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
scrDic.Add dx, arr(i, 4)
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
Parameter3:Dimension
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

mancubus
06-07-2018, 02:01 AM
post your workbook pls
(see 2 in my signature)

input and output tables' parameters do not match.

Oran
06-07-2018, 01:14 PM
post your workbook pls
(see 2 in my signature)

input and output tables' parameters do not match.
22380

mancubus
06-08-2018, 02:31 AM
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

Oran
06-13-2018, 06:12 AM
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

Please assist
Thank you in advance

Oran
06-13-2018, 07:24 AM
Nevermind. I fixed it. I changed "xlPivotTableVersion15' to xlPivotTableVersion14