Sub es()
Dim t(), t1(), x As Long, i As Long, c As Long, z As Long
Application.ScreenUpdating = False
Range("A4:E23").Copy Destination:=[g4]
For z = 1 To [b1]
x = 0
t = Range("g4:k23")
ReDim t1(1 To UBound(t), 1 To 5)
For i = 1 To UBound(t)
x = x + 1
If x = 1 Then t(i, 4) = t(i, 4) * 2: t(i, 5) = t(i, 5) / t(i, 4)
For c = 1 To 5: t1(x, c) = t(i, c): Next c
Next i
[g4].Resize(x, 5) = t1
Erase t, t1
[g4:k23].Sort Key1:=Range("k4"), Order1:=xlDescending, Header:=xlGuess
Next z
End Sub