Getting only the values base on a list - excel

Question

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

Answer 1

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