`Hello SJMaxwell,
The attached workbook uses "Sheet2" for the output. There is a button in the header row to run the macro.
Module1 Macro Code
Option Explicit
Sub Macro1()
Dim Balances As Variant
Dim Cell As Range
Dim Dict As Object
Dim Key As Variant
Dim IdToName As New Collection
Dim Rng As Range
Dim RngBeg As Range
Dim RngEnd As Range
Dim WksDst As Worksheet
Dim WksSrc As Worksheet
Set WksDst = ThisWorkbook.Worksheets("Sheet2")
Set WksSrc = ThisWorkbook.Worksheets("Sheet1")
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
'// Find the Source Worksheet header "Loc Name".
Set Cell = WksSrc.UsedRange.Find("Loc Name", , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
'// This collection returns the location name for an identifier.
While Cell <> ""
On Error Resume Next
IdToName.Add Cell.Value, Cell.Offset(0, 1).Value
Set Cell = Cell.Offset(1, 0)
On Error GoTo 0
Wend
'// Find the Source Worksheet header "Date".
Set RngBeg = WksSrc.Cells.Find("Date", , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
Set RngEnd = WksSrc.Cells(Rows.Count, RngBeg.Column).End(xlUp)
Set Rng = WksSrc.Range(RngBeg.Offset(1, 0), RngEnd)
For Each Cell In Rng.Cells
Key = Trim(Cell.Offset(0, 2))
If Key <> "" Then
If Not Dict.Exists(Key) Then
Dict.Add Key, CStr(Cell.Offset(0, 1).Value)
Else
Dict(Key) = Dict(Key) & "+" & Cell.Offset(0, 1)
End If
End If
Next Cell
'// Clear the Destination Worksheet except for the column headers.
Set Rng = WksDst.UsedRange
Set Rng = Intersect(Rng, Rng.Offset(1, 0))
If Not Rng Is Nothing Then Rng.ClearContents
'// Set the starting range on the Destination Worksheet.
Set Rng = WksDst.Range("A2")
'// Output the results to the Destination Worksheet.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each Key In Dict.Keys
Balances = Split(Dict(Key), "+")
Rng.Resize(1, 2).Value = Array(Key, IdToName(Key))
Rng.Offset(0, 2).Resize(1, UBound(Balances) + 1).Value = Balances
Rng.Offset(0, 18).Value = Dict(Key)
Rng.Offset(0, 19).Value = "=" & Dict(Key)
Set Rng = Rng.Offset(1, 0)
Next Key
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
End Sub
Bookmarks