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

Question

我有一个包含 500 个条目并包含 20 列的 excel 表。下面是 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 代码将 Jan、Dec、Nov、Oct 月份转换为 Month 列 我希望我已经解释清楚了。

请帮助编写 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

结束子

感谢您的帮助。

Answer 1

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

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

数据的结构应该和下图中单元格地址的位置一致。

数据表

成绩单