Как преобразовать значение столбца в строки в макросе vba

Question

У меня есть лист 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 Таблица источника ввода выглядит так.

How can i convert Jan,Dec,Nov,Oct month into Month column with VBA excel code I hope i have explained well.

Please help to write VBA code of that. Out put table look like that

введите описание изображения здесь

Сегодня я получил такое же решение, думаю, поделится с каждым.

Ниже приведен код вышеуказанного требования.

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

End Sub

спасибо за помощь.

Answer 1

Вы можете накапливать данные, используя динамические c массивы.

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

Структура данных должна быть такой же, как расположение адреса ячейки на рисунке ниже.

Технический паспорт

Result Sheet

введите описание изображения здесь