vba script for % price change over the period

Hi folks,

I got this vba script from the experts in the thread "New worksheet based on multiple worksheets". This is pulling out the relevant information from the multiple sheets against the unique transactions. Please refer in the sample data attached.

I wish to add one more in the "output" sheet as % price change over the transactions date. This should come out from the "cost" column in the "transactions" sheet, example: for first transaction "12345678" it should be (4 - 2.14)/2.14 = 87% for the period of 13/01/2020-09/09/2020. Hope I am clear with the need. I have tried to modify the code accordingly but messed it up and couldn't got anything at the end, then thought of reaching out to the experts again. TIA...

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

Originally Posted by AlphaFrog

Sub DataTest_V4()
    Dim vT, v, vv, vMin, vMax
    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
        vMin = d.items
        .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
        vMax = d.items
        .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
        
        'Percent Change
        For i = LBound(vMin) To UBound(vMin)
            If vMin(i) > 0 Then vMin(i) = (vMax(i) - vMin(i)) / vMin(i)
        Next i
        .Cells(2, 8).Resize(UBound(vMin) + 1) = Application.Transpose(vMin)
        
        With .UsedRange
            .Columns("A:B").NumberFormat = "@"
            .Columns("C").NumberFormat = "#,##0"
            .Columns("D").NumberFormat = "d/m/yyyy"
            .Columns("E:G").NumberFormat = "$* #,##0.00"
            .Columns("H").NumberFormat = "0.0%"
        End With
        
    End With
    
    MsgBox Timer - t
End Sub

Thanks AlphaFrog for replying. It is absolutely working fine where the prices have been increased over the time but it is not where the prices have been decreased, example, for item #23456789, the % change should be (21-32)/32 = -34% instead of 52.4%. Please refer in the attached.

Thanks man, superb...this is exactly what i need

Regards,
Abhi