Классическое Транспонирование
После написания этого он больше не выглядит классическим.
Код
Sub ClassicalTranspose()
Const cVntSource As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cVntTarget As Variant = "Sheet2" ' Target Worksheet Name/Index
Const cStrSource As String = "A1:H14" ' Source Range
Const cStrTarget As String = "A1" ' Target Cell Range
Const cInt1 As Integer = 1 ' First Repeat Column
Const cInt2 As Integer = 2 ' Last Repeat Column
Const cStr1 As String = "Year" ' First New Column Header
Const cStr2 As String = "Value" ' Second New Column Header
Dim vntRep As Variant ' Repeat Array
Dim vntUni As Variant ' Unique Array
Dim vntTgt As Variant ' Target Array
Dim intRep1 As Integer ' First Column of Repeat Range
Dim intRep2 As Integer ' Last Column of Repeat Range
Dim intUni1 As Integer ' First Column of Unique Range
Dim intUni2 As Integer ' Last Column of Unique Range
Dim lngFirst As Long ' First Row of Source Range
Dim lngLast As Long ' Last Row of Source Range
Dim i As Long ' Source Arrays Row Counter
Dim j As Integer ' Source Arrays Column Counter
Dim k As Long ' Target Array Row Counter
Dim l As Integer ' Unique Array Column Counter
' Paste Source Range into Source Arrays (Repeat and Unique Arrays).
With ThisWorkbook.Worksheets(cVntSource).Range(cStrSource)
intRep1 = .Column + cInt1 - 1
intRep2 = .Column + cInt2 - 1
intUni1 = .Column + cInt2
intUni2 = .Columns.Count + .Column - 1
lngFirst = .Row
lngLast = .Rows.Count + .Row - 1
With .Parent
vntRep = .Range(.Cells(lngFirst, intRep1), .Cells(lngLast, intRep2))
vntUni = .Range(.Cells(lngFirst, intUni1), .Cells(lngLast, intUni2))
End With
End With
' Resize Target Array.
ReDim vntTgt(1 To (UBound(vntUni) - 1) * UBound(vntUni, 2) + 1, _
1 To UBound(vntRep, 2) + 2)
' Write Repeat to Target Array
For j = 1 To UBound(vntRep, 2)
vntTgt(1, j) = vntRep(1, j)
Next
k = 1
For l = 1 To UBound(vntUni, 2)
For i = 2 To UBound(vntRep)
k = k + 1
For j = 1 To UBound(vntRep, 2)
vntTgt(k, j) = vntRep(i, j)
Next
Next
Next
' Write Unique to Target Array
vntTgt(1, 1 + UBound(vntRep, 2)) = cStr1
vntTgt(1, 1 + UBound(vntRep, 2) + 1) = cStr2
k = 1
For j = 1 To UBound(vntUni, 2)
For i = 2 To UBound(vntUni)
k = k + 1
vntTgt(k, 1 + UBound(vntRep, 2)) = vntUni(1, j)
vntTgt(k, 2 + UBound(vntRep, 2)) = vntUni(i, j)
Next
Next
' Paste Target Array into Target Range.
With ThisWorkbook.Worksheets(cVntTarget).Range(cStrTarget)
.Resize(UBound(vntTgt), UBound(vntTgt, 2)) = vntTgt
End With
End Sub