Grouping, Summing, and Displaying data based off of user inputs

Hi,

check the file attached..Amount.xlsm

code:

Sub GetAmount()

    Dim dic As Object
    Dim aData(), dKey, aDataout()
    Dim i As Long, j As Long
    
    aData = ActiveSheet.Cells(1, 1).CurrentRegion.Value
    
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(aData, 1) + 1 To UBound(aData, 1)
        dKey = aData(i, 1) & vbNullChar & aData(i, 2) & vbNullChar & aData(i, 3) & vbNullChar & aData(i, 4)
        dic(dKey) = dic(dKey) + aData(i, 5)
    Next i
    
    ReDim aDataout(1 To dic.Count + 1, 1 To UBound(aData, 2))
    For i = 1 To UBound(aData, 2)
        aDataout(1, i) = aData(1, i)
    Next i
    
    i = 2
    For Each dKey In dic.Keys
        For j = LBound(Split(dKey, vbNullChar)) To UBound(Split(dKey, vbNullChar))
            aDataout(i, j + 1) = Split(dKey, vbNullChar)(j)
        Next j
        aDataout(i, j + 1) = dic(dKey)
        i = i + 1
    Next dKey
    
    ThisWorkbook.Worksheets.Add.Cells(1, 1).Resize(UBound(aDataout, 1), UBound(aDataout, 2)).Value = aDataout

End Sub

Sorry forgot that, please check this where the user can enter Date, Site and Brand Amount.xlsm

Or with an pivot table.

See the attached file.

How would columns F and G be displayed when summing the qty, are we checking that these are the same?

output to E10 in activesheet:

ActiveSheet.Cells(10, 5).Resize(UBound(aDataout, 1), UBound(aDataout, 2)).Value = aDataout

Hi,

could you please create a sample workbook and fill it with dummy data, I fear my example a few posts above is no longer valid

Please check: Test.xlsm

Hi,

looks like there is no dictionary object for mac, however I found a custom one, please test the attachment

Hi,

commented code:

Option Explicit

Sub GetAmount()

    Dim dic         As Object   'main dictionary: each entry is one output record idetified by the concatenation of "Site Brand Style"
    Dim dicChild    As Object   'child dictionary: each entry on the main dic contains another child dic. This child dic has 3 entries, Quantity,Sales and COGS
    Dim dKey        As Variant  'variant to loop the keys in a dictionary

    Dim aData()                 'array with data from worksheet
    Dim aDataout()              'output array
    Dim aUser(3)                'array consisting of conditions entered by user, index 0-3

    Dim strKey      As String   'string holding key
    Dim strStyle    As String   '

    Dim i           As Long     'loop counter
    Dim j           As Long     'loop counter



    strStyle = Sheets("Sales Report").Range("B3").value

    If strStyle = vbNullString Then

        'validation of what the user entered
        With Sheets("Sales Report")
            'start date:
            If IsDate(.Cells(4, 2).value) Then aUser(0) = .Cells(4, 2).value Else MsgBox "enter a date", vbOKOnly + vbExclamation, "Error": Exit Sub
            'end date:
            If IsDate(.Cells(5, 2).value) Then aUser(1) = .Cells(5, 2).value Else MsgBox "enter a date", vbOKOnly + vbExclamation, "Error": Exit Sub
        End With
        With Sheets("Formulas")
            'Site:
            If VBA.Trim$(.Cells(1, 3).value) <> vbNullString Then aUser(2) = .Cells(1, 3).value Else MsgBox "enter sth", vbOKOnly + vbExclamation, "Error": Exit Sub
            'Brand:
            If VBA.Trim$(.Cells(1, 6).value) <> vbNullString Then aUser(3) = .Cells(1, 6).value Else MsgBox "enter sth", vbOKOnly + vbExclamation, "Error": Exit Sub
        End With

        aData = Sheets("Data").Cells(1, 1).CurrentRegion.value  'data from worksheet to array

        Set dic = New Dictionary    'create new dictionary object, see appropriate class module for details
        
        For i = LBound(aData, 1) + 1 To UBound(aData, 1)    'loop data array
            If aData(i, 1) >= aUser(0) And aData(i, 1) <= aUser(1) And aUser(2) = aData(i, 2) And aUser(3) = aData(i, 3) Then   'check is current record satisfies user conditions
                strKey = CStr(aUser(2) & vbNullChar & aUser(3) & vbNullChar & aData(i, 4))  'build key string
                If Not dic.Exists(strKey) Then      'check if entry with that key exists in dictionary
                    Set dicChild = New Dictionary       'if not create another dictionary object ...
                    dicChild.Add CStr(aData(1, 5)), 0   'and add 3 items to it with value 0: Quantity
                    dicChild.Add CStr(aData(1, 6)), 0   'Sales
                    dicChild.Add CStr(aData(1, 7)), 0   'COGS
                    dic.Add strKey, dicChild            'Add child dic to main dic
                End If
                
                dic.Item(strKey).Item(CStr(aData(1, 5))) = dic.Item(strKey).Item(CStr(aData(1, 5))) + aData(i, 5)   'Quantity: add current number to number in child dic for
                dic.Item(strKey).Item(CStr(aData(1, 6))) = dic.Item(strKey).Item(CStr(aData(1, 6))) + aData(i, 6)   'Sales: add current number to number in child dic for
                dic.Item(strKey).Item(CStr(aData(1, 7))) = dic.Item(strKey).Item(CStr(aData(1, 7))) + aData(i, 7)   'COGS: add current number to number in child dic for
            End If
        Next i
        Set dicChild = New Dictionary: Set dicChild = Nothing   'clear child dic

        If dic.Count = 0 Then MsgBox ("nothing found"): Exit Sub    'if no records satisfied conditions the main dic is empty -> exit sub

        ReDim aDataout(1 To dic.Count + 1, 1 To UBound(aData, 2) - 1)   'prepare output array by adding headers from input array
        For i = 2 To UBound(aData, 2)
            aDataout(1, i - 1) = aData(1, i)
        Next i

        i = 2
        For Each dKey In dic.Keys   'loop keys/items in the main dic
            For j = LBound(Split(dKey, vbNullChar)) To UBound(Split(dKey, vbNullChar))  'loop the 3 parts of the main dic key to get the values for "Site Brand Style" to the array
                aDataout(i, j + 1) = Split(dKey, vbNullChar)(j)
            Next j
            For j = 4 To 6          'loop the child dic to get the amounts to the array
                aDataout(i, j) = dic.Item(CStr(dKey)).Item(CStr(aDataout(1, j)))
            Next j
            i = i + 1
        Next dKey

        ActiveSheet.Cells(10, 5).CurrentRegion.ClearContents    'clear range from previous output data
        ActiveSheet.Cells(10, 5).Resize(UBound(aDataout, 1), UBound(aDataout, 2)).value = aDataout      'output array to worksheet

    Else
        MsgBox ("In order to see a breakdown by style you must delete any data in cell B3")
    End If

    Set dic = Nothing   'clear main dic

End Sub

To get an idea of dictionaries check:
http://excelicious.wordpress.com/201...vs-collection/
http://www.techbookreport.com/tutori...ictionary.html

Please note: As there is no build in Dictionary Object for Mac a custom one was written as close as possible to the original one, however there might be differences in assigning values to items

Replace the entire code in module1 with the following:

Option Explicit

Enum enProfile
    All = 0
    Site = 1
    SiteBrand = 2
    SiteGen = 3
End Enum

Dim lngProfile As Long
Dim aDataout() As Variant

Sub GetAmount()

    Dim dic As Object, dicChild As Object
    Dim aData(), dKey, cKey, aUser(4)
    Dim strKey As String
    Dim i As Long, j As Long


    If Sheets("Sales Report").Range("B3").value = vbNullString Then

        'validation of what the user entered
        With Sheets("Sales Report")
            'start date:
            If IsDate(.Cells(5, 2).value) Then aUser(0) = .Cells(5, 2).value Else MsgBox "enter a date", vbOKOnly + vbExclamation, "Error": Exit Sub
            'end date:
            If IsDate(.Cells(6, 2).value) Then aUser(1) = .Cells(6, 2).value Else MsgBox "enter a date", vbOKOnly + vbExclamation, "Error": Exit Sub
        End With
        With Sheets("Formulas")
            'Site:
            aUser(2) = .Cells(1, 3).value
            'Brand:
            aUser(3) = .Cells(1, 6).value
            'Gender
            aUser(4) = .Cells(1, 15).value
        End With

        'set profile
        If aUser(2) <> 0 And aUser(3) <> 0 And aUser(4) <> 0 Then
            lngProfile = enProfile.All
        ElseIf aUser(2) <> 0 And aUser(3) = 0 And aUser(4) = 0 Then
            lngProfile = enProfile.Site
        ElseIf aUser(2) <> 0 And aUser(3) <> 0 And aUser(4) = 0 Then
            lngProfile = enProfile.SiteBrand
        ElseIf aUser(2) <> 0 And aUser(3) = 0 And aUser(4) <> 0 Then
            lngProfile = enProfile.SiteGen
        Else
            MsgBox "Please enter at least one restriction.", vbCritical + vbOKOnly, "Error"
            Exit Sub
        End If

        aData = Sheets("Data").Cells(1, 1).CurrentRegion.value

        Set dic = New Dictionary
        For i = LBound(aData, 1) + 1 To UBound(aData, 1)
            If ValidateRecord(aUser, aData, i) Then
                strKey = GetDicKey(aUser, aData, i)
                If Not dic.Exists(strKey) Then
                    Set dicChild = New Dictionary
                    dicChild.Add CStr(aData(1, 5)), 0
                    dicChild.Add CStr(aData(1, 7)), 0
                    dicChild.Add CStr(aData(1, 8)), 0
                    dic.Add strKey, dicChild
                End If
                dic.Item(strKey).Item(CStr(aData(1, 5))) = dic.Item(strKey).Item(CStr(aData(1, 5))) + aData(i, 5)
                dic.Item(strKey).Item(CStr(aData(1, 7))) = dic.Item(strKey).Item(CStr(aData(1, 7))) + aData(i, 7)
                dic.Item(strKey).Item(CStr(aData(1, 8))) = dic.Item(strKey).Item(CStr(aData(1, 8))) + aData(i, 8)
            End If
        Next i
        Set dicChild = New Dictionary: Set dicChild = Nothing

        If dic.Count = 0 Then
            MsgBox "Nothing found", vbOKOnly + vbExclamation, "End"
            ClearResult
            Exit Sub
        End If

        PrepareOutputArray aData, dic.Count

        i = 2
        For Each dKey In dic.Keys
            aDataout(i, 1) = Split(dKey, vbNullChar)(0)
            
            Select Case lngProfile
                Case enProfile.All
                    aOut = Array(Split(dKey, vbNullChar)(1), Split(dKey, vbNullChar)(3), Split(dKey, vbNullChar)(2))
                Case enProfile.Site
                    aOut = Array(vbNullString, Split(dKey, vbNullChar)(1), vbNullString)
                Case enProfile.SiteBrand
                    aOut = Array(Split(dKey, vbNullChar)(1), Split(dKey, vbNullChar)(2), vbNullString)
                Case enProfile.SiteGen
                    aOut = Array(vbNullString, Split(dKey, vbNullChar)(1), Split(dKey, vbNullChar)(2))
            End Select
            
            aDataout(i, 2) = aOut(0)
            aDataout(i, 3) = aOut(1)
            aDataout(i, 4) = aOut(2)
            
            For j = 5 To 7
                aDataout(i, j) = dic.Item(CStr(dKey)).Item(CStr(aDataout(1, j)))
            Next j
            i = i + 1
        Next dKey
        
        ClearResult
        ActiveSheet.Cells(10, 5).Resize(UBound(aDataout, 1), UBound(aDataout, 2)).value = aDataout

        'ThisWorkbook.Worksheets.Add.Cells(1, 1).Resize(UBound(aDataout, 1), UBound(aDataout, 2)).Value = aDataout

    Else
        MsgBox ("In order to see a breakdown by style you must delete any data in cell B3")
    End If

    Set dic = Nothing

End Sub

Private Function ValidateRecord(aUser As Variant, aData As Variant, i As Long) As Boolean
    Select Case lngProfile
        Case enProfile.All
            ValidateRecord = (aData(i, 1) >= aUser(0) And aData(i, 1) <= aUser(1) _
                And aUser(2) = aData(i, 2) And aUser(3) = aData(i, 3) And aData(i, 6) = aUser(4))
        Case enProfile.Site
            ValidateRecord = (aData(i, 1) >= aUser(0) And aData(i, 1) <= aUser(1) _
                And aUser(2) = aData(i, 2))
        Case enProfile.SiteBrand
            ValidateRecord = (aData(i, 1) >= aUser(0) And aData(i, 1) <= aUser(1) _
                And aUser(2) = aData(i, 2) And aUser(3) = aData(i, 3))
        Case enProfile.SiteGen
            ValidateRecord = (aData(i, 1) >= aUser(0) And aData(i, 1) <= aUser(1) _
                And aUser(2) = aData(i, 2) And aData(i, 6) = aUser(4))
    End Select
End Function

Private Function GetDicKey(aUser As Variant, aData As Variant, i As Long) As String
    Select Case lngProfile
        Case enProfile.All
            GetDicKey = CStr(aUser(2) & vbNullChar & aUser(3) & vbNullChar & aUser(4) & vbNullChar & aData(i, 4))
        Case enProfile.Site
            GetDicKey = CStr(aUser(2) & vbNullChar & aData(i, 4))
        Case enProfile.SiteBrand
            GetDicKey = CStr(aUser(2) & vbNullChar & aUser(3) & vbNullChar & aData(i, 4))
        Case enProfile.SiteGen
            GetDicKey = CStr(aUser(2) & vbNullChar & aData(i, 4) & vbNullChar & aUser(4))
    End Select
End Function

Private Sub PrepareOutputArray(aData As Variant, lngCount As Long)
    Dim i As Long, aIndex() As Variant
    Select Case lngProfile
        Case enProfile.All
            aIndex = Array(2, 3, 4, 6, 5, 7, 8)
        Case enProfile.Site
            aIndex = Array(2, 0, 4, 0, 5, 7, 8)
        Case enProfile.SiteBrand
            aIndex = Array(2, 3, 4, 0, 5, 7, 8)
        Case enProfile.SiteGen
            aIndex = Array(2, 0, 4, 6, 5, 7, 8)
    End Select
    
    ReDim aDataout(1 To lngCount + 1, 1 To UBound(aIndex) + 1)
    For i = 1 To UBound(aIndex) + 1
        If aIndex(i - 1) <> 0 Then
            aDataout(1, i) = aData(1, aIndex(i - 1))
        Else
            aDataout(1, i) = vbNullString
        End If
    Next i
End Sub

Private Sub ClearResult()
    With ActiveSheet
        .Cells(10, 5).Resize(.Rows.Count - 11, .Columns.Count - 6).ClearContents
    End With
End Sub

Just declare aOut as a variant in the module

How did you fix the error you reported in post #25?

I just went back in and deleted all the code, and pasted in again and it worked. Then I added "Dim aOut() As Variant" to line 12 per your instructions in post #27.

Hmm, I cannot reproduce that error.

What did you select for
Site - - - - - - - -
Brand - - - - - -
Gender - - - -

What is the value of "dKey" during that error?

What is the value of "aDataout(1, j)" during that error?

Please check if this works on a mac: Test_rs.xlsm

Works perfect on a PC, but I am receiving two errors on a Mac:

Error: 429 (ActiveX component can't create object) in Sub 'PrepareConnction' of Form 'frmKunden'.

When I click OK I get this next one.

Error: 429 (ActiveX component can't create object) in Sub 'Breakdown' Module 'Module2'.

Would be easier with ADO but here is a workaround with the custom dictionary again: Test_3.xlsm

code:

Option Explicit

Enum enProfile
    All = 0
    Site = 1
    SiteBrand = 2
    SiteGen = 3
End Enum

Dim aDataout() As Variant
Dim lngProfile As Long

Sub GetAmount()

    Dim dic As Object, dicChild As Object
    Dim xlRng As Excel.Range
    Dim aData() As Variant, dKey As Variant, aUser(4) As Variant, aOut() As Variant
    Dim strKey As String
    Dim i As Long, j As Long


    On Error GoTo GetAmount_ErrorHandler
    Application.ScreenUpdating = False

    If Sheets("Sales Report").Range("B3").value = vbNullString Then

        'validation of what the user entered
        With Sheets("Sales Report")
            'start date:
            If IsDate(.Cells(5, 2).value) Then aUser(0) = .Cells(5, 2).value Else MsgBox "enter a date", vbOKOnly + vbExclamation, "Error": Exit Sub
            'end date:
            If IsDate(.Cells(6, 2).value) Then aUser(1) = .Cells(6, 2).value Else MsgBox "enter a date", vbOKOnly + vbExclamation, "Error": Exit Sub
        End With
        With Sheets("Formulas")
            'Site:
            aUser(2) = VBA.Trim$(.Cells(1, 3).value)
            'Brand:
            aUser(3) = VBA.Trim$(.Cells(1, 6).value)
            'Gender
            aUser(4) = VBA.Trim$(.Cells(1, 15).value)
        End With

        'set profile
        If aUser(2) <> 0 And aUser(3) <> 0 And aUser(4) <> 0 Then
            lngProfile = enProfile.All
        ElseIf aUser(2) <> 0 And aUser(3) = 0 And aUser(4) = 0 Then
            lngProfile = enProfile.Site
        ElseIf aUser(2) <> 0 And aUser(3) <> 0 And aUser(4) = 0 Then
            lngProfile = enProfile.SiteBrand
        ElseIf aUser(2) <> 0 And aUser(3) = 0 And aUser(4) <> 0 Then
            lngProfile = enProfile.SiteGen
        Else
            MsgBox "Please enter at least one restriction.", vbCritical + vbOKOnly, "Error"
            Exit Sub
        End If
        

        aData = Sheets("Data").Cells(1, 1).CurrentRegion.value


        Set dic = New Dictionary
        For i = LBound(aData, 1) + 1 To UBound(aData, 1)
            If ValidateDate(aUser, aData, i) Then
                strKey = GetDicKey(aData, i)
                If Not dic.Exists(strKey) Then
                    Set dicChild = New Dictionary
                    For j = 6 To 8
                        dicChild.Add CStr(aData(1, j)), 0
                    Next j
                    dic.Add strKey, dicChild
                End If
                For j = 6 To 8
                    dic.Item(strKey).Item(CStr(aData(1, j))) = CLng(dic.Item(strKey).Item(CStr(aData(1, j)))) + aData(i, j)
                Next j
            End If
        Next i
        Set dicChild = New Dictionary: Set dicChild = Nothing


        If dic.Count = 0 Then
            MsgBox "Nothing found", vbOKOnly + vbExclamation, "End"
            ClearResult
            Exit Sub
        End If


        PrepareOutputArray aData, dic.Count


        i = 2
        For Each dKey In dic.Keys
            If ValidateKey(aUser, dKey) Then
                
                For j = 0 To 3
                    aDataout(i, j + 1) = Split(dKey, vbNullChar)(j)
                Next j
                
                For j = 5 To 7
                    aDataout(i, j) = dic.Item(CStr(dKey)).Item(CStr(aDataout(1, j)))
                Next j
                
                i = i + 1
                
            End If
        Next dKey
        
        
        ClearResult
        With ActiveSheet
            Set xlRng = .Cells(10, 5).Resize(UBound(aDataout, 1), UBound(aDataout, 2))
            xlRng.value = aDataout   'paste result to sheet
            
            'sort:
            With .Sort.SortFields
                .Clear
                .Add Key:=xlRng.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=xlRng.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=xlRng.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=xlRng.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
                .SetRange xlRng
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
        End With
            

    Else
        MsgBox ("In order to see a breakdown by style you must delete any data in cell B3")
    End If

    
GetAmount_Proc_Exit:
    Set dic = Nothing
    Application.ScreenUpdating = True
    Exit Sub
GetAmount_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'GetAmount' of Module 'Module1'.", vbOKOnly + vbCritical, "Error"
    Resume GetAmount_Proc_Exit

End Sub

Private Function ValidateDate(aUser As Variant, aData As Variant, i As Long) As Boolean
    ValidateDate = (aUser(0) <= aData(i, 1) And aData(i, 1) <= aUser(1))
End Function

Private Function GetDicKey(aData As Variant, i As Long) As String
    GetDicKey = VBA.Join(Array(aData(i, 2), aData(i, 3), aData(i, 4), aData(i, 5)), vbNullChar)
End Function

Private Function ValidateKey(aUser As Variant, ByVal strKey) As Boolean
    Dim aTmp As Variant
    aTmp = VBA.Split(strKey, vbNullChar)
    Select Case lngProfile
        Case enProfile.All
            ValidateKey = (aUser(2) = aTmp(0) And aUser(3) = aTmp(1) And aUser(4) = aTmp(3))
        Case enProfile.Site
            ValidateKey = (aUser(2) = aTmp(0))
        Case enProfile.SiteBrand
            ValidateKey = (aUser(2) = aTmp(0) And aUser(3) = aTmp(1))
        Case enProfile.SiteGen
            ValidateKey = (aUser(2) = aTmp(0) And aUser(4) = aTmp(3))
    End Select
End Function

Private Sub PrepareOutputArray(aData As Variant, lngCount As Long)
    Dim i As Long
    ReDim aDataout(1 To lngCount + 1, 1 To 7)
    For i = 1 To 7
        aDataout(1, i) = aData(1, i + 1)
    Next i
End Sub

Private Sub ClearResult()
    With ActiveSheet
        .Cells(10, 5).Resize(.Rows.Count - 11, .Columns.Count - 6).ClearContents
    End With
End Sub