如何复制和转置VBA

Question

我的代码打击只进行了3年（2016年，2017年和2018年）。但是现在我又增加了4年，但是我不知道如何适应描述，因此我在Q Ark1行上增加了4个班级和4个班级。因此它适用于2016年至2022年。下面添加了代码，它将信息从Ark2转换为Ark1。

我真的希望你能提供帮助。

Sub TransposeAH()

    Const cSheet1 As Variant = "Ark2"   ' Sheet1 Name/Index
    Const cSheet2 As Variant = "Ark1"   ' Sheet2 Name/Index
    Const cFirst As Integer = 23       ' 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