Sub testro()
Const cSheet As String = "Procenty"
    Const cRange As String = "A2:D71"
    Const cel As Long = 4
    Const cCol As Variant = "A"


    Dim vntS As Variant
    Dim vntT As Variant
    Dim i As Long, r As Long
    Dim emptyRow As Long

    Dim kom As Double, komz As Double, kredyt As Double
    Dim roz As Double, komr As Double, komn As Double
    Dim dz As Date, dw As Date

    vntS = ThisWorkbook.Worksheets(cSheet).Range(cRange).Value
    ReDim vntT(1 To 3 * UBound(vntS), 1 To cel + 1)
    kredyt = 0

    r = 1

    For i = 1 To UBound(vntS)

        dz = vntS(i, 1)
        komz = vntS(i, 2)
        dw = vntS(i, 3)
        kom = vntS(i, 4)



       If komz > kom Then

If CStr(vntT(r, 1)) = "" Then
   vntT(r, 1) = dz
   vntT(r, 2) = komz 'debt
End If
vntT(r, 3) = dw
vntT(r, 4) = kom 'payment
vntT(r, 5) = " komz>kom"

r = r + 1

komz = komz - kom

    vntT(r, 1) = dz
    vntT(r, 2) = komz ' Debt
    vntT(r, 3) = dw
    vntT(r, 4) = kom  '  payment
    vntT(r, 5) = " .. komz > kom"



ElseIf komz < kom Then

    komn = kom - komz

    vntT(r, 1) = dz
vntT(r, 2) = komz
vntT(r, 3) = dw
vntT(r, 4) = kom
vntT(r, 5) = " .. A"

r = r + 1

    vntT(r, 3) = dw
    vntT(r, 4) = komn  ' Overpaid
    vntT(r, 5) = " .. komz < kom"

    r = r + 1

ElseIf komz = kom Then
    vntT(r, 1) = dz
    vntT(r, 2) = komz  ' debt
    vntT(r, 3) = dw
    vntT(r, 4) = kom   ' payment
    vntT(r, 5) = " .. komz = kom"

    r = r + 1

End If


    Next

    With ThisWorkbook.Worksheets(cSheet)
        emptyRow = .Columns(cCol).Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious).Row + 1
        .Cells(emptyRow, cCol).Resize(UBound(vntT), UBound(vntT, 2)) = vntT
        .Cells(emptyRow, cCol) = kredyt
    End With
End Sub