Returning A Sum From Multiple Occurences

Hello cdwelch4,

The attached workbook has the macro below. A button on the worksheet runs the macro. The output list of part numbers and their required totals appears in column "J:K" on the same sheet.

Sub Macro1()

    Dim AssyQty As Variant
    Dim Cell    As Range
    Dim Count   As Long
    Dim Dict    As Object
    Dim Jobs    As Range
    Dim Key     As Variant
    Dim SrcRng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        Set SrcRng = Wks.Range("A1").CurrentRegion
        Set DstRng = Wks.Range("J1:K1")
        
            DstRng.Value = Array("Part #", "Total Req'd")
        
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            Set SrcRng = Intersect(SrcRng, SrcRng.Offset(2, 1))
            
            For r = 1 To SrcRng.Rows.Count
                Key = SrcRng.Item(r, 1)
                AssyQty = SrcRng.Item(r, 2)
                Set Jobs = Intersect(SrcRng.Rows(r), SrcRng.Rows(r).Offset(0, 2))
                    If Not IsNumeric(AssyQty) Then
                        Count = Application.Sum(Jobs)
                    Else
                        Count = AssyQty * Application.Sum(Jobs)
                    End If
                If Not IsEmpty(Key) Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, Count
                    Else
                        Count = Dict(Key) + Count
                        Dict(Key) = Count
                    End If
                End If
            Next r
            
        r = 0
        For Each Key In Dict.Keys
            r = r + 1
            DstRng.Offset(r, 0).Value = Array(Key, Dict(Key))
        Next Key
        
End Sub

Hello cdwelch4,

This macro is a augmented version of the previous one. This list the Part Number, Jobs, Job counts, and the Total for each job starting in column "J". The output list is now sorted from smallest to largest part number.

Here is the improved code...

Option Explicit

Sub Macro1()

    Dim AssyQty As Variant
    Dim Cell    As Range
    Dim Count   As Variant
    Dim Counts  As Variant
    Dim Dict    As Object
    Dim DstRng  As Range
    Dim Header  As Variant
    Dim Jobs    As Range
    Dim Key     As Variant
    Dim n       As Long
    Dim r       As Long
    Dim SrcRng  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        Set SrcRng = Wks.Range("A1").CurrentRegion
        Set DstRng = Wks.Range("J1")
        
            ReDim Header(SrcRng.Columns.Count - 3 + 1)
                Header(0) = "Part #"
                Header(UBound(Header)) = "Total"
            
                For n = 1 To UBound(Header) - 1
                    Header(n) = SrcRng.Cells(2, n + 3)
                Next n
                
          ' Format the header row of the destination.
            Set DstRng = DstRng.Resize(1, UBound(Header) + 1)
            DstRng.Value = Header
            DstRng.Font.Bold = True
            DstRng.HorizontalAlignment = xlHAlignRight
        
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            Set SrcRng = Intersect(SrcRng, SrcRng.Offset(2, 1))
            
            For r = 1 To SrcRng.Rows.Count
                Key = SrcRng.Item(r, 1)
                
                AssyQty = SrcRng.Item(r, 2)
                    If Not IsNumeric(AssyQty) Then AssyQty = 1 Else AssyQty = CDbl(AssyQty)
                    
                Set Jobs = Intersect(SrcRng.Rows(r), SrcRng.Rows(r).Offset(0, 2))
                    ReDim Counts(1 To Jobs.Columns.Count + 1)
                    n = 0
                    For Each Count In Jobs
                        n = n + 1
                        Counts(n) = AssyQty * Count.Value
                    Next Count
                    
                If Not IsEmpty(Key) Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, Counts
                    Else
                        Counts = Dict(Key)
                        n = 0
                        For Each Count In Jobs
                            n = n + 1
                            Counts(n) = Counts(n) + (AssyQty * Count.Value)
                        Next Count
                        Dict(Key) = Counts
                    End If
                End If
            
           Next r
            
      ' Output the Part Numbers and Job Numbers with their individual and total counts.
        Application.ScreenUpdating = False
            r = 0
            For Each Key In Dict.Keys
                r = r + 1
                DstRng.Offset(r, 0).Value = Key
                Counts = Dict(Key)
                Counts(UBound(Counts)) = Application.Sum(Counts)
                DstRng.Offset(r, 1).Resize(1, Jobs.Columns.Count + 1).Value = Counts
            Next Key
        
          ' Sort the Parts Numbers from smallest to largest.
            Set DstRng = DstRng.Resize(RowSize:=r)
        
            Wks.Sort.SortFields.Clear
            Wks.Sort.SortFields.Add Key:=DstRng.Item(2, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        
            With Wks.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SetRange DstRng
                .Apply
            End With
        Application.ScreenUpdating = True
        
End Sub