CODEWITHSUNDEEP
excelvba
Mc837
Mc837

Reputation: 59

VBA: List unique items with associated values and given certain conditions

So I've been trying to tackle this from different angles and hitting walls each time. I'm not familiar with VBA so the data structures are also an issue. A pivot table isn't really an option as I'd like to add further logic later on.

The goal is to sort through several sheets of data, summing 2 values associated to keys, to output a column with unique keys and 2 columns with the sum of the respective values.

For example, Input:

John    10    5    TRUE
Mary    11    7    TRUE
John    1     1    FALSE
Susan   20    9    TRUE
Mary    0     0    TRUE
Susan   2     8    FALSE
John    3     12   TRUE

Desired output:

John    13    17
Mary    11    7
Susan   20    9

So far, I have been able to extract a list of unique names as a collection, and print it out. For efficiency's sake, I'd like to try and do the sums at the same time (instead of then going through all the data using unique names as an index to sum).

As far as I'm aware, I shouldn't be using a Collection as they do not allow for updating the item value once set, and because a duplicate key would throw an error (thus not letting me update the values). I tried using Dictionaries but having 2 objects (one for each associated value) with the same keys seems redundant and error-prone. Before trying Arrays I'd like to know if I'm wasting my time and there's a better approach/data structure to use, keeping in mind I also need to output these 3 columns to a separate sheet, so an easy to print solution would be ideal.

Any guidance on how I should be doing this? It really doesn't seem that complicated, but I'm finding it hard to come across good documentation. Thanks in advance!

Upvotes: 0

Views: 76

Answers (2)

Storax
Storax

Reputation: 12167

If you want to do it with VBA using a dictionary you could try the following code. I took your example data and assumed they are in sheet1 starting in A1. You need to modify the code for your needs.

Main Module

Option Explicit

Public Sub CreateReport()

    ' Turn off functionality such as auto calculations
    'TurnOffFunctionality

    ' Read the data into a dictionary
    Dim dict As Scripting.Dictionary
    Set dict = ReadFromData()

    ' write the data to the report worksheet
    WriteReport dict

    ' Turn functionality back on
    'TurnOnFunctionality

End Sub

Module for reading the data

Option Explicit
Const COL_DATA_NAME = 1
Const COL_VALUE1 = 2
Const COL_VALUE2 = 3
Const COL_ADD = 4

Function ReadFromData() As Scripting.Dictionary

    On Error GoTo EH

    Dim dict As New Scripting.Dictionary

    ' Get the data range
    Dim rgData As Range
    Set rgData = Sheet1.Range("A1:D7")  ' asumption data is in A1:D7

    Dim FirstName As String
    Dim value1 As Long, value2 As Long
    Dim nameCalcs As Calcs
    Dim add As Boolean

    ' Go through each row
    Dim rgCurRow As Range
    For Each rgCurRow In rgData.Rows

        ' Read the row data to variables
        FirstName = rgCurRow.Cells(1, COL_DATA_NAME)
        value1 = rgCurRow.Cells(1, COL_VALUE1)
        value2 = rgCurRow.Cells(1, COL_VALUE2)
        add = rgCurRow.Cells(1, COL_ADD)


        ' If FirstName one is not already in dictionary then add
        If Not dict.Exists(FirstName) Then
            Set nameCalcs = New Calcs
            dict.add FirstName, nameCalcs
        End If

        ' Update the data holder for each FirstName with new values based on the current values
        If add Then
            dict(FirstName).Sum1 = dict(FirstName).Sum1 + value1
            dict(FirstName).Sum2 = dict(FirstName).Sum2 + value2
        End If

    Next rgCurRow

    Set ReadFromData = dict

Done:
    Exit Function
EH:
    ' Your error message
End Function

Module for writing the data

Option Explicit
Const REP_COL_FNAME = 1
Const REP_COL_SUM1 = 2
Const REP_COL_SUM2 = 3
Public Sub WriteReport(dict As Scripting.Dictionary)

    On Error GoTo EH

    ' Clear the Report area
    'ClearReportArea   You need to do that on your own

    ' Write the report data
    WriteDataToReport dict

Done:
    Exit Sub
EH:
    MsgBox Err.Description & ". Procedure is: Report_Write.TurnOnFunctionality."
End Sub

Private Sub WriteDataToReport(dict As Scripting.Dictionary)

    On Error GoTo EH

    ' Get variable to track the rows
    Dim rowCnt As Long
    rowCnt = 1

    ' Go through each FirstName in the dictionary
    Dim k As Variant
    For Each k In dict.Keys

        ' Write the data to the report sheet from the data holder
        Dim rgStart As Range
        Set rgStart = Sheet1.Range("F1")
        With dict(k)
            rgStart.Offset(rowCnt, REP_COL_FNAME) = k
            rgStart.Offset(rowCnt, REP_COL_SUM1) = .Sum1
            rgStart.Offset(rowCnt, REP_COL_SUM2) = .Sum2
        End With

        rowCnt = rowCnt + 1

    Next k

Done:
    Exit Sub
EH:
    ' Your error mesaage
End Sub

And the class Calcs

Option Explicit

Public Sum1 As Long
Public Sum2 As Long

Upvotes: 1

Gary's Student
Gary's Student

Reputation: 96753

There is a tiny trick to allow you to do this efficiently.

Say in input data is in worksheet input and we have another worksheet called output.

In output cell B1 enter:

=IF(A1="","",SUMPRODUCT(--(input!$A$1:$A$999=A1)*(input!$D$1:$D$999=TRUE)*(input!$B$1:$B$999)))

and copy down. In output cell C1 enter:

=IF(A1="","",SUMPRODUCT(--(input!$A$1:$A$999=A1)*(input!$D$1:$D$999=TRUE)*(input!$C$1:$C$999)))

and copy down.

The output sheet is now ready to receive the unique names from column A of the input sheet (basically the formulas in output will not have to be re-entered or modified; if there are no names in column A, then B and C will appear empty). You can populate column A with:

Sub GetNames()
    Dim s1 As Worksheet, s2 As Worksheet

    Set s1 = Sheets("input")
    Set s2 = Sheets("output")

    s2.Columns(1).Clear
    s1.Columns(1).Copy s2.Columns(1)
    s2.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Upvotes: 0

Related Questions