Consulting

Results 1 to 10 of 10

Thread: Sum for a certain criteria

  1. #1
    VBAX Regular
    Joined
    Jun 2018
    Posts
    15
    Location

    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. #2
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    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.

    vbax_62884_pt.jpg
    Last edited by mancubus; 06-04-2018 at 06:43 AM.
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  3. #3
    VBAX Regular
    Joined
    Jun 2018
    Posts
    15
    Location
    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. #4
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    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.
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  5. #5
    VBAX Regular
    Joined
    Jun 2018
    Posts
    15
    Location
    Quote Originally Posted by mancubus View Post
    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 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

  6. #6
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    post your workbook pls
    (see 2 in my signature)

    input and output tables' parameters do not match.
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  7. #7
    VBAX Regular
    Joined
    Jun 2018
    Posts
    15
    Location
    Quote Originally Posted by mancubus View Post
    post your workbook pls
    (see 2 in my signature)

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

  8. #8
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    "Where I lay my head is home" :D
    Posts
    2,644
    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
    Last edited by mancubus; 06-08-2018 at 06:12 AM. Reason: typo corrected; with / end with block added
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  9. #9
    VBAX Regular
    Joined
    Jun 2018
    Posts
    15
    Location
    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

  10. #10
    VBAX Regular
    Joined
    Jun 2018
    Posts
    15
    Location
    Nevermind. I fixed it. I changed "xlPivotTableVersion15' to xlPivotTableVersion14

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •