My code below gives me a result with a unique customer codes base on Calculation sheet. However, I want to get my result base on the list that I have in Solution Sheet. Also want to run the macro within Solution Sheet. Any help will be appreciated.

Calculation Sheet

Solution Sheet

Sub cTotals()

Dim arr, arr2, arr3
Dim Calc As Worksheet: Set TS = Worksheets("Calculation")
Dim Sol As Worksheet: Set Sol = Worksheets("Solution")
Dim x As Long, i As Long, a As Long, c As Long, ct As Long
Dim GIVMM As Single, MSU As Double, Cases As Double
    
    
arr = Calc.Range("B2:H" & Cells(Rows.Count, 1).End(xlUp).Row)
arr2 = arr
With CreateObject("Scripting.Dictionary")
For x = LBound(arr) To UBound(arr)
    If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
Next
arr = .Keys
End With
ReDim arr3(1 To UBound(arr)   1, 1 To 7)
c = 1: ct = 1
For i = 0 To UBound(arr)
    For a = 1 To UBound(arr2)
        If arr2(a, 1) = arr(i) Then
            arr3(i   1, c) = arr(i)
            arr3(i   1, c   1) = ct
            ct = ct   1
            GIVMM = GIVMM   arr2(a, 5)
            arr3(i   1, c   2) = GIVMM
            MSU = MSU   arr2(a, 6)
            arr3(i   1, c   3) = MSU
            Cases = Cases   arr2(a, 7)
            arr3(i   1, c   4) = Cases
        End If
    Next
    ct = 1: GIVMM = 0: MSU = 0: Cases = 0
Next
Sol.Range("B6").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3

End Sub

CodePudding user response：

Using Data Structures (Array, Collection, Dictionary)

Option Explicit

Sub CalculateData()
    
    ' Define constants.
    
    ' Source
    Const sName As String = "Calculation"
    Const scCol As Long = 2
    Dim sCols() As Variant: sCols = VBA.Array(4, 6, 7, 8)
    ' Destination
    Const dName As String = "Solution"
    Const dfRow As Long = 6
    Const dcCol As Long = 2
    Const dColumnOffset As Long = 1
    Dim dOffsets() As Variant: dOffsets = VBA.Array(1, 2, 3, 4)
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Write the values from the source range ('srg') to an array ('sData').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim sData() As Variant: sData = srg.Value
    Dim srCount As Long: srCount = srg.Rows.Count
    
    ' Write the unique source values to the 'keys' ('sString')
    ' of a dictionary ('sDict'). Its 'items' ('sDict(sString)') will hold
    ' a collection of all the (source) rows ('r') where the 'key' appeared.
    
    Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
    sDict.CompareMode = vbTextCompare
    
    Dim sString As String
    Dim r As Long
    
    For r = 2 To srCount
        sString = CStr(sData(r, scCol))
        If Len(sString) > 0 Then
            If Not sDict.Exists(sString) Then
                Set sDict(sString) = New Collection
            End If
            sDict(sString).Add r
        End If
    Next r
    
    ' Write the values from the destination lookup column range ('dlrg')
    ' to a 2D one-based (one-column) array ('dlData').
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dcCol).End(xlUp).Row
    Dim drCount As Long: drCount = dlRow - dfRow   1
    
    If drCount < 1 Then
        MsgBox "No data in the destination column.", vbCritical
        Exit Sub
    End If
    
    Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dcCol).Resize(drCount)
    
    Dim dlData() As Variant
    
    If drCount = 1 Then ' one cell
        ReDim dlData(1 To 1, 1 To 1): dlData(1, 1) = dlrg.Value
    Else ' multiple cells
        dlData = dlrg.Value
    End If
    
    ' Write the results to the destination array ('dData').
    
    Dim cUpper As Long: cUpper = UBound(sCols)
    Dim cCount As Long: cCount = cUpper   1
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
    dDict.CompareMode = vbTextCompare
    
    Dim sItem As Variant
    Dim sValue As Variant
    Dim dString As String
    Dim c As Long
    
    For r = 1 To drCount
        dString = CStr(dlData(r, 1))
        If Len(dString) > 0 Then
            If sDict.Exists(dString) Then ' found in the dictionary
                For Each sItem In sDict(dString) ' loop through the rows
                    For c = 0 To cUpper
                        If c = 0 Then ' unique count
                            sString = CStr(sData(sItem, sCols(c)))
                            dDict(sString) = Empty
                        Else ' sum
                            sValue = sData(sItem, sCols(c))
                            If VarType(sValue) = vbDouble Then ' is a number
                                dData(r, c   1) = dData(r, c   1)   sValue
                            'Else ' is not a number; do nothing
                            End If
                        End If
                    Next c
                Next sItem
                dData(r, 1) = dDict.Count
                dDict.RemoveAll
            ' Else ' not found in the dictionary; do nothing
            End If
        ' Else ' vbNullString ('""'); do nothing
        End If
    Next r
        
    ' Write the values from the destination array to the destination range.
        
    With dws.Cells(dfRow, dcCol).Offset(, dColumnOffset)
        .Resize(drCount, cCount).Value = dData
    End With
    
    ' Inform.
    MsgBox "Data calculated.", vbInformation
    
End Sub