How to duplicate and transpose VBA - excel

Question

My code blow, was made for only 3 years, (2016, 2017 & 2018). but now i have added 4 more years, but i dont know how to fit the description, so that i adds 4 more classes and four more on row Q Ark1. So that it fits with years 2016 to 2022. The code is added below, it transposes the information from Ark2 to Ark1.
I really hope you can help.
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