Hello dh507249 and welcome to the forum,
As per forum rules, please change the title of you thread to better describe your problem.http://www.excelforum.com/forum-rule...rum-rules.html
Here's a code that should help you :
Sub FlatFile()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ar
Dim i As Long, j As Long, k As Integer
Dim Dict, e, a, b
Dim Max As Integer, Tot As Double
Application.ScreenUpdating = False
Set ws1 = Sheets("Original_v2")
Set ws2 = Sheets("Final_v2")
ar = ws1.Cells(1).CurrentRegion
Set Dict = CreateObject("Scripting.Dictionary")
'Compile Data
For i = 1 To UBound(ar, 1)
If ar(i, 3) <> "" Then
If Not Dict.exists(ar(i, 2)) Then
Dict.Add ar(i, 2), ar(i, 3) & Chr(2) & ar(i, 1) & Chr(2) & ar(i, 4)
Else
Dict.Item(ar(i, 2)) = Dict.Item(ar(i, 2)) & Chr(2) & ar(i, 1) & Chr(2) & ar(i, 4)
End If
End If
Next i
'Output results
a = Dict.keys
b = Dict.items
For i = 0 To Dict.Count - 1
e = Split(b(i), Chr(2))
Max = WorksheetFunction.Max(Max, UBound(e))
ws2.Cells(i + 1, 1) = a(i)
ws2.Cells(i + 1, 2).Resize(1, UBound(e) + 1) = e
Next i
'Total and header
Max = Max + 3
For i = 1 To Dict.Count - 1
Tot = 0
k = 1
For j = 4 To Max Step 2
Tot = Tot + ws2.Cells(i + 1, j)
ws2.Cells(1, j) = "Amount " & k
ws2.Cells(1, j - 1) = "Date " & k
k = k + 1
ws2.Cells(i + 1, j) = CDbl(ws2.Cells(i + 1, j))
ws2.Cells(i + 1, j).NumberFormat = "# ##0.00;-# ##0.00;"
Next j
ws2.Cells(i + 1, Max) = Tot
ws2.Cells(i + 1, Max).NumberFormat = "# ##0.00;-# ##0.00;"
Next i
'Foramt Sheet
With ws2
.Cells(1).CurrentRegion.ColumnWidth = 15
.Rows(1).Font.Bold = True
.Cells(1, Max) = "Total"
End With
Application.ScreenUpdating = True
End Sub
Bookmarks