VBA to Get Sum of Data and Write to another Worksheet

[lharr28]

I'm trying to create a trend analysis that shows the total spent for each account code. I want to sum the total for each account code, by year, and place the information on another worksheet, called "Results". Included in that information I would like the heading titles for the sum of that account code listed as well. The data will come from the worksheet called "DATA". Below I've included screenshots mock worksheets and of the vba code I tried.

I've tried to use a for loop that I found on another site, but I'm not sure if I'm headed down the right path or if it is even possible to do what I'm asking. I know the code isn't correct. I used their example as a guide. Any guidance would be greatly appreciate!

"DATA" Worksheet

"RESULTS" Worksheet - Empty

"RESULTS" Worksheet - How I want it to look after the vba code but of course with data input into every field. All of the information for every field can be found in the "DATA" worksheet.

' IMPORTANT: Add the Dictionary reference to use the dictionary
'            Tools->Reference and check "Microsoft Scripting Runtime"
' https://excelmacromastery.com/
Sub ForDictionary_Assign_Sum()

    ' PART 1 - Read the data
    ' Get the worksheets
    Dim shRead As Worksheet
    Set shRead = ThisWorkbook.Worksheets("DATA")
    
    ' Get the range
    Dim rg As Range
    Set rg = shRead.Range("A1").CurrentRegion
    
    ' Create the dictionary
    Dim dict As New Dictionary
    
    ' Read through the data
    Dim i As Long, SpeedType As String, MonetaryAmount As Long, Account As Long
    For i = 2 To rg.Rows.Count
        ' Store the values in a variable
        SpeedType = rg.Cells(i, 1).Value2
        MonetaryAmount = rg.Cells(i, 68).Value2
        Account = rg.Cells(i, 8).Value2
        
        ' The item will be automatically added if it doesn't exist
        dict(SpeedType) = dict(SpeedType) + Account + MonetaryAmount
    Next i
    
    ' PART 2 - Write the data
    Dim shWrite As Worksheet
    Set shWrite = ThisWorkbook.Worksheets("Reports")
    
    With shWrite
    
        ' Clear the data in output worksheet
        .Cells.ClearContents
        
        ' Set the cell formats
        '.Columns(2).NumberFormat = "$#,##0;[Red]$#,##0"
        
        ' Write header
        .Cells(1, 1).Value2 = "SpeedType"
        .Cells(1, 2).Value2 = "Account"
        .Cells(1, 3).Value2 = "MonetaryAmount"
        
    End With
    
    Dim key As Variant, row As Long
    row = 2
    ' Read through each item in the Dictionary
    For Each key In dict.Keys
    
        shWrite.Cells(row, 1) = key
        shWrite.Cells(row, 2) = dict(key)
        
        row = row + 1
    Next key
    
End Sub

The Results of my VBA Code

 

[6StringJazzer]

I'm 99% sure that you can do this without VBA in Microsoft 365, which you have.

total spent for each account code

Which column is the "account code"? I do not see a column with that heading. If it's the data in DATA column H, Results column Q, I don't understand your results because 52109 is duplicated.

All of the information for every field can be found in the "DATA" worksheet.

Not at all clear what that mapping is.

 

[kvsrinivasamurthy]

Pl upload the given data in XL2BB format.

 

[lharr28]

I'm 99% sure that you can do this without VBA in Microsoft 365, which you have.


Which column is the "account code"? I do not see a column with that heading. If it's the data in DATA column H, Results column Q, I don't understand your results because 52109 is duplicated.


Not at all clear what that mapping is.

Sorry for the confusion, I tried to be as clear as I could. The account codes are in column H. So there may be multiple account codes for the same SpeedType. What I want to do is sum each account code for each Speedtype and keep certain columns that are linked to the SpeedType like the dept #, dept, program #, program...all of this information is found in the "DATA" worksheet.

I'm unable to download the XL2BB to my computer. However, here's a link to the file, MrExcel Example. Please let me know if this works. Thanks.

 

[lharr28]

Pl upload the given data in XL2BB format.

Hi, I'm unable to download the XL2BB to my computer. However, here's a link to the file, MrExcel Example. Please let me know if this works. Thanks.

 

[6StringJazzer]

sum each account code for each Speedtype and keep certain columns that are linked to the SpeedType like the dept #, dept, program #, program

None of that was mentioned in your first post, hence my puzzlement.

The linked file is much better than using XL2BB, I'll take a look.

 

[6StringJazzer]

The headings from RESULTS shown in red below do not have a matching heading on the DATA sheet. I cannot see how those should be populated. I also don't know where you are getting the numbers in RESULTS columns S:W.

The problem here is the Curse of Knowledge. You know everything about what you want to do, but we know nothing about what you want to do. You have to explain it remembering that we have never seen this before and have no idea what you have in mind.

 

[kvsrinivasamurthy]

Try this on a copy file.

Sub UpdateResults()
Dim A, Sn
Dim Dic As Object
Dim Lrd&, Lrr&, Ta&, Tb&, Ros&, strg$

With Sheets("DATA")
Lrd = .Range("A" & Rows.Count).End(xlUp).Row
A = .Range("A2:BP" & Lrd)
End With
Set Dic = CreateObject("scripting.dictionary")

With Dic
For Ta = 1 To UBound(A, 1)
strg = A(Ta, 1) & "-" & A(Ta, 25) & "-" & A(Ta, 26) & "-" & A(Ta, 8) & "-" & A(Ta, 9) & "-" & A(Ta, 31)

If Not .exists(strg) Then
Sn = Array(A(Ta, 1), A(Ta, 25), A(Ta, 26), A(Ta, 8), A(Ta, 9), A(Ta, 31), 0, 0, 0)
.Item(strg) = Sn
End If

Sn = .Item(strg)
If A(Ta, 31) = 2023 Then
Sn(6) = Sn(6) + A(Ta, 68)
ElseIf A(Ta, 31) = 2024 Then
Sn(7) = Sn(7) + A(Ta, 68)
ElseIf A(Ta, 31) = 2025 Then
Sn(8) = Sn(8) + A(Ta, 68)
End If
.Item(strg) = Sn
Sn = ""

Next Ta
Ros = .Count
End With

With Sheets("Results")
Lrr = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A6:X" & Lrr).Clear

With .Range("A6").Resize(Ros, 1)
.Offset(0, 0) = WorksheetFunction.Index(Dic.items, 0, 1)
.Offset(0, 9) = WorksheetFunction.Index(Dic.items, 0, 2)
.Offset(0, 10) = WorksheetFunction.Index(Dic.items, 0, 3)
.Offset(0, 16) = WorksheetFunction.Index(Dic.items, 0, 4)
.Offset(0, 17) = WorksheetFunction.Index(Dic.items, 0, 5)
.Offset(0, 18) = WorksheetFunction.Index(Dic.items, 0, 7)
.Offset(0, 19) = WorksheetFunction.Index(Dic.items, 0, 8)
.Offset(0, 20) = WorksheetFunction.Index(Dic.items, 0, 9)

End With
End With
End Sub

 

[Fuji]

Here's another method.

Sub test()
    Dim cn$, sq$, x&, ws As Worksheet
    Set ws = Sheets("results")
    x = ws.Cells.SpecialCells(11).Row
    If x > 5 Then ws.Rows("6:" & x).Clear
    cn = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=No';"
    sq = "Select F1, 8# F25, F26, 5# F8, F9, " & _
        "IIf(F31 = '2023', Sum(F68),0), IIf(F31 = '2024', Sum(F68),0), " & _
        "IIf(F31 = '2025', Sum(F68),0) From `Data$A2:DJ` Where F1 Is Not Null " & _
        "Group By F1, F8, F9, F25, F26, F31;"
    sq = Replace(Replace(sq, "5#", Application.Rept("Null, ", 5)), _
        "8#", Application.Rept("Null, ", 8))
    With CreateObject("ADODB.Recordset")
        .Open sq, cn
        ws.[a6].CopyFromRecordset .DataSource
    End With
End Sub