Таблица Excel VBA: Кто-нибудь знает, как это сделать?

Question

Кто-нибудь знает, как изменить это значение с 2 на 1 .Я имею в виду первые 4 строки, поэтому они соответствуют операторам if в приведенном выше коде и работают со всеми данными.Я изменил код из ответа на другой мой вопрос.Я понимаю код ответа, который я изменил, но теперь я застрял и не знаю, что с ним делать.Я попытался i=i+1, но он перезаписывает значения.

Sub testo()

    Const cSheet As String = "Procenty"   
    Const cRange As String = "A2:D73"     
    Const cel As Long = 4             
    Const cCol As Variant = "A"           

    Dim vntS As Variant   
    Dim vntT As Variant   
    Dim i As Integer     
    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)

    ReDim vntT(1 To UBound(vntS), 1 To cel)

    kredyt = 0
    For i = 1 To UBound(vntS)
        If vntS(i, 1) = "" Then
            dw = Date
        Else
            dz = vntS(i, 1)
        End If

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

        If kom = komz Then

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

        ElseIf komz > kom Then
            komr = komz - kom
            vntT(i, 1) = dz
            vntT(i, 2) = komz
            vntT(i, 3) = dw
            vntT(i, 4) = kom
            vntT(i + 1, 1) = dz
            vntT(i + 1, 2) = komr
            vntT(i + 1, 3) = dw
            vntT(i + 1, 4) = kom

        ElseIf komz < kom Then
            komn = kom - komz
            vntT(i, 1) = dz
            vntT(i, 2) = komz
            vntT(i, 3) = dw
            vntT(i, 4) = kom
            vntT(i + 1, 3) = dw
            vntT(i + 1, 4) = komn

        End If

    Next

    With ThisWorkbook.Worksheets(cSheet)

        emptyRow = .Columns(cCol).Find("*", , xlFormulas, _
        xlWhole, xlByColumns, xlPrevious).Row + 1
'emptyRow = WorksheetFunction.CountA(.Columns(cCol)) + 1
' wypisywanie tablicy
        .Cells(emptyRow, cCol).Resize(UBound(vntT), UBound(vntT, 2)) = vntT
        .Cells(emptyRow, cCol) = kredyt
    End With
End Sub

Answer 1

Это мое лучшее предположение ...

Sub testo()

    Const cSheet As String = "Procenty"
    Const cRange As String = "A2:D73"
    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 2 * UBound(vntS), 1 To cel) '<< add space for extra rows

    kredyt = 0
    r = 1 '<< "row" counter for vntT
    For i = 1 To UBound(vntS)

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

        vntT(r, 1) = dz
        vntT(r, 2) = komz
        vntT(r, 3) = dw
        vntT(r, 4) = kom
        r = r + 1

        If komz > kom Then
            komr = komz - kom
            vntT(r, 1) = dz
            vntT(r, 2) = komr
            vntT(r, 3) = dw
            vntT(r, 4) = kom
            r = r + 1
        ElseIf komz < kom Then
            komn = kom - komz
            vntT(r, 3) = dw
            vntT(r, 4) = komn
            r = r + 1
        End If
    Next

    'etc...

End Sub