Excel 如何在vba宏中将列值转换为行

我有一个excel工作表，有500个条目，包含20列。下面是excel工作表源的一部分

CollegeId| Name| Rollnumber| Department| 'Januar 2020| 'Dezember 2019| November 2019 |'Oktober 2019 |4 Months Averge |4 months Sum.

一行数据集

4|ABC|DE010|IT|348140|168277|245604|103109|216283|865133|98253|11790337

excel标题的输出

CollegeId| Name| Rollnumber| Department|Month|4 Months Averge |4 months Sum

 4|ABC|DE010|IT|'Januar 2020|348140|216283|865132|98253|1179036
4|ABC|DE010|IT|'Dezember 2019|168277|216283|865132|98253|1179036
4|ABC|DE010|IT|November 2019|348140|216283|865132|98253|1179036
4|ABC|DE010|IT|'Oktober 2019|348140|216283|865132|98253|1179036

这是Excel工作表输入源表的样子

如何使用VBA excel代码将一月、十二月、十一月、十月转换为月份列 我希望我解释得很好

请帮我写VBA代码吧。 把桌子放出来，像那样

今天我得到了同样的解决方案，我想分享给大家

以下是上述要求的代码

Sub TransposeData()

Dim LastRowRawDataSheet As Long, LastRowTransposeDetailsSheet As Long
Dim CurrentData As Range, MonthRange As Range

Application.ScreenUpdating = False

'Last Row Raw Data Sheet
LastRowRawDataSheet = RawDataSheet.Cells(Rows.Count, "A").End(xlUp).Row

'Last Row Transpose Details Sheet
LastRowTransposeDetailsSheet = TransposeDetailsSheet.Cells(Rows.Count, "A").End(xlUp).Row

'Clear Data --> Transpose Details Sheet
If LastRowTransposeDetailsSheet > 1 Then
    TransposeDetailsSheet.Range("A2:F" & LastRowTransposeDetailsSheet).Clear
End If

'Month Range
Set MonthRange = RawDataSheet.Range("E1:H1")

TransposeDetailsSheet.Activate

For Each CurrentData In RawDataSheet.Range("A2:A" & LastRowRawDataSheet)

    'Roll No.
    TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "A").Value = CurrentData.Value
        
    'Name
    TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "B").Value = CurrentData.Offset(, 1).Value
    
    'Id
    TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "C").Value = CurrentData.Offset(, 2).Value
    
    'DEPT
    TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "D").Value = CurrentData.Offset(, 3).Value
    
    'Fill Down
    TransposeDetailsSheet.Range(TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "A"), TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "D")).AutoFill TransposeDetailsSheet.Range(TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "A"), TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 4, "D")), xlFillDefault
    
    'Copy Month
    MonthRange.Copy
    
    'Paste Month into Transpose Details Sheet -->  Month
    TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "E").PasteSpecial xlPasteValuesAndNumberFormats, xlPasteSpecialOperationNone, False, True
    Application.CutCopyMode = False
    
    'Copy Data from "E:H" Column
    RawDataSheet.Range(RawDataSheet.Cells(CurrentData.Row, "E"), RawDataSheet.Cells(CurrentData.Row, "H")).Copy
    
    'Paste into Transpose Details --> Record
    TransposeDetailsSheet.Cells(LastRowTransposeDetailsSheet + 1, "F").PasteSpecial xlPasteValuesAndNumberFormats, xlPasteSpecialOperationNone, False, True
    Application.CutCopyMode = False
    
    'Last Row Transpose Data Sheet
    LastRowTransposeDetailsSheet = TransposeDetailsSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
Next CurrentData

TransposeDetailsSheet.Activate
TransposeDetailsSheet.Range("A1").Activate

Application.ScreenUpdating = True

端接头

---

谢谢您的帮助。

您可以使用动态数组积累数据

Sub test()
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim r As Long, i As Long, n As Long
    Dim k As Integer, j As Integer
    
    Set Ws = Sheets(1) '<~~ Data Sheet
    Set toWs = Sheets(2) '<~~ Result Sheet
    
    vDB = Ws.UsedRange
    
    r = UBound(vDB, 1)
    
    For i = 2 To r
        If vDB(i, 1) <> "" Then
            For j = 5 To 8
                n = n + 1
                ReDim Preserve vR(1 To 10, 1 To n)
                For k = 1 To 4
                    vR(k, n) = vDB(i, k)
                Next k
                vR(5, n) = vDB(1, j)
                vR(6, n) = vDB(i, j)
                For k = 7 To 10
                    vR(k, n) = vDB(i, k + 2)
                Next k
            Next j
        End If
    Next i
    With toWs
        .UsedRange.Offset(1).Clear
        .Range("a2").Resize(n, 10) = WorksheetFunction.Transpose(vR)
    End With
            
End Sub

子测试（）
将Ws设置为工作表
将拖缆变暗为工作表
Dim vDB，vR（）
暗r一样长，i一样长，n一样长
将k作为整数，j作为整数
设置Ws=Sheets（1）'您的数据和图像的内容似乎不一致。