How to convert column value to rows in vba Macro

Question

I have a excel sheet that have 500 entries and contain 20 columns .Below is part of the excel sheet source.

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

One row of dataset

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

Output of excel header.

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

This is Excel sheet Input source table look like.

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

Today i got solution for same ,i think share to every one.

Below is code of above requirement.

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

thanks for help.

Answer 1

You can accumulate data using dynamic arrays.

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

The structure of the data should be the same as the location of the cell address in the figure below.

Data Sheet

Result Sheet