excel - 如何将列值转换为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

结束子

感谢帮助。

标签： excelvbaexcel-formula

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

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

数据表

结果表