Getting only the values base on a list

Francease

New Member
Joined
Jul 4, 2022
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
Using this code below gives me a result of 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 in button inside Solution sheet. Any help will be appreciated.

Calculation Sheet
TRANSACTION.jpg


Solution Sheet
example.jpg


VBA Code:
Public Sub cTotal()

    Dim arr, arr2, arr3
    Dim Calc As Worksheet: Set Calc = 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
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
See if this works for you.

VBA Code:
Public Sub cTotal_Mod()

    Dim calcArr, solArr, arr3
    Dim Calc As Worksheet: Set Calc = 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
    Dim CustCode As String
    Dim solDict As Object
        
    calcArr = Calc.Range("A2:H" & Calc.Cells(Rows.Count, "A").End(xlUp).Row)
    solArr = Sol.Range("B6:F" & Sol.Cells(Rows.Count, "B").End(xlUp).Row)
    
    Set solDict = CreateObject("Scripting.Dictionary")
    For x = 1 To UBound(solArr)
        solDict(solArr(x, 1)) = x
    Next

    For i = 1 To UBound(calcArr)
        CustCode = calcArr(i, 2)
        GIVMM = calcArr(i, 6)
        MSU = calcArr(i, 7)
        Cases = calcArr(i, 8)
        
        If solDict.exists(CustCode) Then
            solArr(solDict(CustCode), 2) = solArr(solDict(CustCode), 2) + 1
            solArr(solDict(CustCode), 3) = solArr(solDict(CustCode), 3) + GIVMM
            solArr(solDict(CustCode), 4) = solArr(solDict(CustCode), 4) + MSU
            solArr(solDict(CustCode), 5) = solArr(solDict(CustCode), 5) + Cases
        End If
    Next i

    Sol.Range("B6").Resize(UBound(solArr, 1), UBound(solArr, 2)) = solArr
End Sub
 
Upvote 0
Solution
Thanks you very much! This is what exactly what I was looking for.
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top