Hello jmerry1,
The attached workbook has the macro below to condense the information. "Sheet2" is formatted the same as "Sheet1" and has a button to run the macro. The condensed results are copied to "Sheet2". The original information on "Sheet1" is not changed.
Sub CondenseData()
Dim Cell As Range
Dim DstRng As Range
Dim Dict As Object
Dim Key As Variant
Dim N As Long, R As Long
Dim SrcRng As Range
Dim RngEnd As Range
Set SrcRng = Worksheets("Sheet1").Range("A2:L2")
Set DstRng = Worksheets("Sheet2").Range("A2:L2")
Set RngEnd = SrcRng.Parent.Cells(Rows.Count, "A").End(xlUp)
Set SrcRng = IIf(RngEnd.Row < SrcRng.Row, SrcRng, SrcRng.Parent.Range(SrcRng, RngEnd))
DstRng.Parent.UsedRange.Offset(1, 0).ClearContents
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
For Each Cell In SrcRng.Columns(2).Cells
Key = Trim(Cell.Value)
If Key <> "" Then
If Not Dict.Exists(Key) Then
N = Cell.Row - SrcRng.Row + 1
DstRng.Offset(R, 0).Value = SrcRng.Rows(N).Value
Dict.Add Key, R
R = R + 1
Else
With DstRng.Offset(Dict(Key), 0)
.Item(1, 8) = .Item(1, 8) + Cell.Offset(0, 6).Value 'Billing
.Item(1, 10) = .Item(1, 10) & ";" & Cell.Offset(0, 8).Value 'Trans Status
.Item(1, 11) = .Item(1, 11) & ";" & Cell.Offset(0, 9).Value 'Rsn Codes
.Item(1, 12) = .Item(1, 12) & ";" & Cell.Offset(0, 10).Value 'Rsn Desc
End With
End If
End If
Next Cell
End Sub
Bookmarks