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