My 2 cent.
Op je datablad kan je niet veel doen aangezien je zelf zegt dat de ranges constant veranderen.
Ik ben er van uit gegaan dat de eerste waarde (verschillend van 0) ook steeds de laagste is. Als dit niet het geval is dan graag een seintje.
Voor de rest gewoon op de knop op blad 2 drukken voor resultaten.
Sub tst()
With Sheets("Blad 1")
sn = .Cells(1).CurrentRegion
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With CreateObject("scripting.dictionary")
For i = 2 To UBound(sn)
x0 = .Item(sn(i, 1))
Next
nRow = .Count
Sheets("Blad 2").Cells(1).CurrentRegion.Offset(1).ClearContents
Sheets("Blad 2").Cells(2, 1).Resize(.Count) = Application.Transpose(.keys)
End With
With Sheets("Blad 2")
For Each cl In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
.Range("R2") = cl.Value
Sheets("Blad 1").Range("A1:G" & lRow).AdvancedFilter 2, .Range("R1:R2"), .Range("R4:X4")
sRow = .Range("R" & .Rows.Count).End(xlUp).Row
cl.Offset(, 1) = Evaluate("=SMALL(x5:x" & sRow & ",1+COUNTIF(x5:x" & sRow & ",0))")
cl.Offset(, 2) = .Range("X" & sRow - 1)
cl.Offset(, 3).FormulaR1C1 = "=(RC[-1]-RC[-2])/RC[-2]"
Next
.Range("D2").Resize(nRow).NumberFormat = "0.00%"
.Range("R2").ClearContents: .Range("R4").CurrentRegion.Offset(1).ClearContents
End With
End Sub