Копирование и умножение описания данных для соответствия VBA

Question

Я впервые настроил свой VBA, чтобы он взял данные и описание за 2019-2021 годы. но теперь мне нужно с 2016 по 2021 год, теперь он копирует данные просто отлично, но не может получить описание, чтобы следовать теперь двойному объему данных. Код для перемещения данных находится под фотографией. Он берет описание от Ark2 и копирует в Ark1.

если вы хотите, чтобы я добавил остальную часть своего кода, я могу, но эта часть кода - это перемещающиеся данные. У меня есть это в модуле для обоих файлов.

Sub TransposeAH()

    Const cSheet1 As Variant = "Ark2"   ' Sheet1 Name/Index
    Const cSheet2 As Variant = "Ark1"   ' Sheet2 Name/Index
    Const cFirst As Integer = 13         ' First Row Number
    Const cCol1First As Variant = "A"   ' Range1 First Column Letter/Number
    Const cCol1Last As Variant = "C"    ' Range1 Last Column Letter/Number
    Const cCol2First As Variant = "E"   ' Range2 First Column Letter/Number
    Const cCol2Last As Variant = "G"    ' Range2 Last Column Letter/Number
    Const cColumns As Integer = 1    ' Number of New Columns
    Const cFirstCell As String = "N1"   ' Target Range First Cell Address

    Dim vntH As Variant  ' Range2 Headers
    Dim vnt2 As Variant  ' Range2 Array
    Dim vnt3 As Variant  ' Range1 Temp Array (if value is "")
    Dim vnt1 As Variant  ' Range1 Array
    Dim vntT As Variant  ' Target Array
    Dim LastUR As Long   ' Last Used Row
    Dim i As Long        ' Arrays Row Counter
    Dim j As Integer     ' Arrays Column Counter
    Dim k As Long        ' Target Array Rows Counter
    Dim m As Integer     ' Range1 Temp Array Column Counter
   ' From Sheet1 to Arrays.
    With Worksheets(cSheet1)
     ' Calculate Last Used Row.
       With .Range(.Cells(cFirst, cCol1First), .Cells(.Rows.Count, cCol2Last))
           If .Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Exit Sub
          LastUR = .Find("*", , , , , 2).Row
        End With
       ' Paste ranges into arrays.
        vnt1 = .Range(.Cells(cFirst, cCol1First), .Cells(LastUR, cCol1Last))
        vnt2 = .Range(.Cells(cFirst, cCol2First), .Cells(LastUR, cCol2Last))
        vntH = .Range(.Cells(cFirst - 1, cCol2First), _
                .Cells(cFirst - 1, cCol2Last))
    End With

    ' Resize Target Array.
    ReDim vntT(1 To UBound(vnt2) * UBound(vnt2, 2), _
            1 To cColumns + UBound(vnt1, 2))

    ' Write Range2 Array to Target Array.
    For i = 1 To UBound(vnt2)
        For j = 1 To UBound(vnt2, 2)
            k = k + 1
            vntT(k, 1) = vntH(1, j)
            vntT(k, 2) = vnt2(i, j)
        Next
    Next

    ' Resize Range1 Temp Array (if value is "")
    ReDim vnt3(1 To 1, 1 To UBound(vnt1, 2))
    ' Copy first line of Range1 Array to Range1 Temp Array.
    For m = 1 To UBound(vnt3, 2)
        vnt3(1, m) = vnt1(1, m)
    Next

    ' Write Range1 Array to Target Array.
    k = 0
    For i = 1 To UBound(vnt1)
        For j = 1 To UBound(vnt1, 2)
            k = k + 1
            For m = 1 To UBound(vnt2, 2)
                If vnt1(i, m) <> "" Then
                    If vnt1(i, m) <> vnt3(1, m) Then
                        vnt3(1, m) = vnt1(i, m)
                    End If
                End If
                vntT(k, m + cColumns) = vnt3(1, m)
            Next
        Next
    Next

    ' Paste Target Array into Target Range resized
    ' from Target Range First Cell Address.
    With Worksheets(cSheet2).Range(cFirstCell)
        .Resize(UBound(vntT), UBound(vntT, 2)) = vntT
    End With


    End Sub