Option Explicit
Sub DataTest_V3()
Dim vT, v, vv
Dim i As Long, d As Object
Dim t As Double
t = Timer
vT = Range("Transactions!A1").CurrentRegion.Value2
Set d = CreateObject("Scripting.Dictionary")
With Worksheets("Output")
.Cells(1, 1).CurrentRegion.Offset(1).Clear
'Item and Description Transactions
For i = 2 To UBound(vT)
d.Item(vT(i, 1)) = vT(i, 2)
Next i
.Cells(2, 1).Resize(d.Count) = Application.Transpose(d.keys)
.Cells(2, 2).Resize(d.Count) = Application.Transpose(d.items)
d.RemoveAll
'Quantity Transactions
For i = 2 To UBound(vT)
d.Item(vT(i, 1)) = d.Item(vT(i, 1)) + vT(i, 4)
Next i
.Cells(2, 3).Resize(d.Count) = Application.Transpose(d.items)
v = d.items
d.RemoveAll
'First Issue Date Transactions
For i = 2 To UBound(vT)
If IsEmpty(d(vT(i, 1))) Then
d.Item(vT(i, 1)) = vT(i, 3)
Else
d.Item(vT(i, 1)) = WorksheetFunction.Min(d.Item(vT(i, 1)), vT(i, 3))
End If
Next i
.Cells(2, 4).Resize(d.Count) = Application.Transpose(d.items)
d.RemoveAll
'Minimum Cost Transactions
For i = 2 To UBound(vT)
If IsEmpty(d(vT(i, 1))) Then
d.Item(vT(i, 1)) = vT(i, 6)
Else
d.Item(vT(i, 1)) = WorksheetFunction.Min(d.Item(vT(i, 1)), vT(i, 6))
End If
Next i
.Cells(2, 5).Resize(d.Count) = Application.Transpose(d.items)
d.RemoveAll
'Maximum Cost Transactions
For i = 2 To UBound(vT)
If IsEmpty(d(vT(i, 1))) Then
d.Item(vT(i, 1)) = vT(i, 6)
Else
d.Item(vT(i, 1)) = WorksheetFunction.Max(d.Item(vT(i, 1)), vT(i, 6))
End If
Next i
.Cells(2, 6).Resize(d.Count) = Application.Transpose(d.items)
d.RemoveAll
'Total Cost Transactions
For i = 2 To UBound(vT)
d.Item(vT(i, 1)) = d.Item(vT(i, 1)) + vT(i, 7)
Next i
vv = d.items
d.RemoveAll
'Average Cost Transactions
For i = LBound(v) To UBound(v)
If v(i) = 0 Then
d.Item(i + 1) = 0
Else
d.Item(i + 1) = vv(i) / v(i)
End If
Next i
.Cells(2, 7).Resize(d.Count) = Application.Transpose(d.items)
d.RemoveAll
With .UsedRange
.Columns("A:B").NumberFormat = "@"
.Columns("C").NumberFormat = "#,##0"
.Columns("D").NumberFormat = "d/m/yyyy"
.Columns("E:G").NumberFormat = "$* #,##0.00"
End With
End With
MsgBox Timer - t
End Sub
Bookmarks