VBA Jagged Array Duplicates

Question

I'm new to coding with VBA, and a beginner programmer in general. I have the following simple table (the data keeps getting inputted on daily basis, so it changes):

Item #	Description	Date	Location	Plate	Load	Type	Rate	Cost
0001	des1	30/1/21	Site	ABC123	5	One	typ1	100
0002	des2	30/1/21	Office	ACB465	4	One	typ1	100
0003	des3	30/1/21	Office	ABC789	3	One	typ1	100
0004	des4	30/1/21	Site	ABS741	5	One	typ1	100
0005	des4	31/1/21	Office	ABC852	2	One	typ1	100

I would like to filter this data by specific date first, then delete duplicates in Location while adding the Load for said duplicates.

For example, if I wanted to filter for 30/1/21. It would end up as follows:

Location	Load
Site	10
Office	7

I would then want to put it in one summary cell as follows:

Summary
10 Site, 7 Office

I was able to filter the original table into jagged arrays. The code for that is:

For j = numberSkipD To numberRowsD
    If Worksheets("Disposal Fees").Range("F" & j).Value = Worksheets("Daily Tracking").Range("B2").Value Then
        For k = numberDisposalInformationRaw To numberDisposalLocation
            ReDim Preserve disposalLocation(numberDisposalLocation)
            disposalLocation(numberDisposalLocation) = Worksheets("Disposal Fees").Range("I" & j).Value
 
        Next
        numberDisposalLocation = numberDisposalLocation + 1
 
        For k = numberDisposalInformationRaw To numberDisposalLoad
            ReDim Preserve disposalLoad(numberDisposalLoad)
            disposalLoad(numberDisposalLoad) = Worksheets("Disposal Fees").Range("K" & j).Value
        Next
        numberDisposalLoad = numberDisposalLoad + 1
    End If
Next

I then tried to do the second table above (deleting duplicates and adding the values for said duplicates together) but it is giving me errors, not sure how to solve them. I know they're index errors, but don't know how to fix them. (Please help me with this part, here is the code)

Dim disposalInformationRaw As Variant
    Dim disposalInformationCooked As Variant
    Dim FoundIndex As Variant, MaxRow As Long, m As Long
        
    ReDim disposalInformationCooked(1 To UBound(disposalInformationRaw, 1), 1 To UBound(disposalInformationRaw, 2))
    
    MaxRow = 0
    For m = 1 To UBound(disposalInformationRaw, 1)
        FoundIndex = Application.Match(disposalInformationRaw(m, 1), Application.Index(disposalInformationCooked, 0, 1), 0)

        If IsError(FoundIndex) Then
            MaxRow = MaxRow + 1
            FoundIndex = MaxRow
            disposalInformationCooked(FoundIndex, 1) = disposalInformationRaw(m, 1)
        End If

        disposalInformationCooked(FoundIndex, 2) = Val(disposalInformationCooked(FoundIndex, 2)) + Val(disposalInformationRaw(i, 2))
    Next m
    
    Range("G1").Resize(MaxRow, UBound(disposalInformationCooked, 2)).Value = disposalInformationCooked

I don't think I'd have much trouble finalizing the third part (the summary), but if you know how to do it, please feel free to share how you would approach it. I mostly need help with the second part. I would be more than happy to edit and provide more information if needed. Thanks in advance.

I need to get the final summary. Maybe there is a better way to approach it than what I did, but I'm not sure. — TheMoCrew
– TheMoCrew, Commented Jan 31, 2021 at 6:08

Tim Williams · Accepted Answer · 2021-01-31 17:07:37Z

3

Here's one approach using a dictionary.

dim dict, rw as range, locn, k, msg, theDate

set dict= createobject("scripting.dictionary")

theDate = Worksheets("Daily Tracking").Range("B2").Value

'adjust table range as required
for each rw in worksheets("Disposal Fees").range("F6:K100").rows
   if rw.cells(3).Value = theDate Then              'date match?
       locn = rw.cells(4).Value                     'read location
       dict(locn) = dict(locn) + rw.cells(6).Value  'add load to sum
   end if
next rw

'loop over the dictionary keys and build the output
for each k in dict
    msg = msg & IIf(len(msg) > 0, ", ", "") & dict(k) & " " & k
next k

debug.print msg

edited Jan 31, 2021 at 17:07

answered Jan 31, 2021 at 6:13

Tim Williams

169k8 gold badges104 silver badges144 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

TheMoCrew Over a year ago

I think this is correct, but I think I am messing up the fill in the blanks I filled them as follows, and get some errors: [table range here as ``` worksheets("Disposal Fees").range("F6:K") ``` [location col] as worksheets("Disposal Fees").range("I6:I") [load col] as worksheets("Disposal Fees").range("K6:I") The worksheet I am using as a reference for this is called "Disposal Fees" The columns are: F: date I: Location K: Load

Tim Williams Over a year ago

For rw.cells([here]) just put the column number in the row

VBasic2008 · Accepted Answer · 2021-01-31 09:56:07Z

Sum Unique

Disposal Fees

Daily Tracking

Adjust the values in the constants section.

The Code

Option Explicit

Sub TESTsumByValue()
    
    ' Source
    Const srcName As String = "Disposal Fees"
    Const lCol As Long = 3
    Const kCol As Long = 4
    Const sCol As Long = 6
    Const SumFirst As Boolean = True
    Const KSDel As String = ":"
    Const IDel As String = ", "
    ' Destination
    Const dstName As String = "Daily Tracking"
    ' Define workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
    
    ' Define Source Range (You may have to do something different).
    Dim srg As Range: Set srg = wb.Worksheets(srcName).Range("A1").CurrentRegion
    
    ' Write Criteria to variable.
    Dim drg As Range: Set drg = wb.Worksheets(dstName).Range("B2")
    Dim Criteria As Variant: Criteria = drg.Value
    
    ' Use function to get the result.
    Dim s As String
    s = sumByValue(Criteria, srg, lCol, kCol, sCol, SumFirst, KSDel, IDel)
    Debug.Print s ' "10:Site, 4:Bathroom, 4:Office"
    
    drg.Offset(, 3).Value = s ' writes to 'E2'
    
End Sub

Function sumByValue( _
    ByVal LookupValue As Variant, _
    rng As Range, _
    ByVal LookupColumn As Long, _
    ByVal KeyColumn As Long, _
    ByVal SumColumn As Long, _
    Optional ByVal SumFirst As Boolean = False, _
    Optional ByVal KeySumDelimiter As String = ": ", _
    Optional ByVal ItemsDelimiter As String = ", ") _
As String
    
    ' Validate range ('rng').
    If rng Is Nothing Then Exit Function
    
    ' Write values from range to Data Array ('Data').
    Dim Data As Variant: Data = rng.Value ' 2D one-based array
    
    ' Declare additional variables.
    Dim vKey As Variant ' Current Key Value
    Dim vSum As Variant ' Current Sum Value
    Dim i As Long ' Data Array Row Counter
    
    ' Create a reference to Unique Sum Dictionary (no variable).
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare ' 'A = a'
        
        ' Loop through Data Array ('Data') and write and sumup unique values
        ' to Unique Sum Dictionary.
        For i = 1 To UBound(Data, 1)
            If Data(i, LookupColumn) = LookupValue Then
                vKey = Data(i, KeyColumn)
                If Not IsError(vKey) Then
                    If Len(vKey) > 0 Then
                        vSum = Data(i, SumColumn)
                        If IsNumeric(vSum) Then
                            .Item(vKey) = .Item(vKey) + vSum
                        Else
                            .Item(vKey) = .Item(vKey) + 0
                        End If
                    End If
                End If
            End If
        Next i
        
        ' Validate Unique Sum Dictionary.
        If .Count = 0 Then Exit Function
        
        ' Redefine variables to be reused.
        ReDim Data(1 To .Count) ' Result Array: 1D one-based array
        i = 0 ' Result Array Elements Counter
        
        ' Write results to Result Array.
        If SumFirst Then
            For Each vKey In .Keys
                i = i + 1
                Data(i) = .Item(vKey) & KeySumDelimiter & vKey
            Next vKey
        Else
            For Each vKey In .Keys
                i = i + 1
                Data(i) = vKey & KeySumDelimiter & .Item(vKey)
            Next vKey
        End If
    
    End With
    
    ' Write the elements of Data Array to Result String.
    sumByValue = Join(Data, ItemsDelimiter)

End Function

Collectives™ on Stack Overflow

VBA Jagged Array Duplicates

2 Answers 2

2 Comments

Sum Unique

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

2 Comments

Sum Unique

Comments

Your Answer

Sign up or log in

Post as a guest

Related