Change Table Type into a new table

Question

enter code hereSub Unpivot() Dim lastRow As Long Dim lastCol As Long Dim i As Long Dim j As Long Dim k As Long Dim data() As Variant Dim ws As Worksheet

Set ws = Worksheets("Table")

'Get the range of data
lastRow = Range("A" & Rows.Count).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
data = Range(Cells(1, 1), Cells(lastRow, lastCol)).Value

'Create new headers for the unpivoted data
ws.Range("A1").CurrentRegion.ClearContents
ws.Range("B3:E3").Value = Array("Line", "LOB", "Date", "Value")

'Loop through the data and unpivot
k = 1
For i = 2 To lastRow
    For j = 3 To lastCol
        If j <> 2 And j <> 1 Then 'skip columns A and B
            If IsDate(data(1, j)) Then 'check if column header is a date
                ws.Range("B4").Offset(k, 0).Resize(1, 4).Value = _
                    Array(data(i, 1), data(i, 2), data(1, j), data(i, j))
            Else
                ws.Range("B4").Offset(k, 0).Resize(1, 4).Value = _
                    Array(data(i, 1), data(i, 2), data(1, j), data(i, j))
            End If
            k = k + 1
        End If
    Next j
Next i

End Sub

i have a table as shown in column b to O and i need a vba code that can convert it into table as shown in sample from range R,S,T,u

tried this code but it doesnt do what is required. Sub TransformTable()

' Define variables
Dim i As Long, j As Long
Dim lastRow As Long, lastCol As Long
Dim data As Variant, newData As Variant
Dim ws As Worksheet

' Set initial values
Set ws = ThisWorkbook.Sheets("Table") ' Change the sheet name to your desired sheet name
lastRow = Cells(Rows.Count, "B").End(xlUp).Row ' Find last row with data in column B
lastCol = Cells(6, Columns.Count).End(xlToLeft).Column ' Find last column with data in row 6
data = Range("B6", Cells(lastRow, lastCol)).Value ' Get data from table

' Resize new data array
ReDim newData(1 To UBound(data, 1) * (UBound(data, 2) - 3), 1 To 4)

' Loop through data and transform
For i = 1 To UBound(data, 1)
    For j = 4 To UBound(data, 2)
        newData(((i - 1) * (UBound(data, 2) - 3)) + (j - 3), 1) = data(i, 1) ' Line
        newData(((i - 1) * (UBound(data, 2) - 3)) + (j - 3), 2) = data(i, 2) ' LOB
        newData(((i - 1) * (UBound(data, 2) - 3)) + (j - 3), 3) = data(5, j) ' Date
        newData(((i - 1) * (UBound(data, 2) - 3)) + (j - 3), 4) = data(i, j) ' Value
    Next j
Next i

' Clear old table and paste new data
ws.Range("A1:D1").Value = Array("Line", "LOB", "Date", "Value") ' Add headers
ws.Range("A2").Resize(UBound(newData, 1), UBound(newData, 2)).Value = newData ' Paste new data

End Sub

Answer 1

Transform Data: Unpivot RCV (VBA)

Sub UnpivotRCV()
     
    ' Define constants.
     
    Const SRC_SHEET As String = "Table"
    Const SRC_FIRST_CELL As String = "B5"
    Const CL_ROWS_COUNT As Long = 1
    Const RL_COLS_COUNT As Long = 2
    Const CV_ROW_OFFSET As Long = 1
    Const RV_COL_OFFSET As Long = 0
    
    Const DST_SHEET As String = "Table"
    Const DST_FIRST_CELL As String = "R6"
    Const DST_HD_ROW_OFFSET As Long = 2
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read: write the source values to arrays.
     
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    If sws.FilterMode Then sws.ShowAllData
    
    Dim cData(), rData(), vData(), srCount As Long, scCount As Long
    
    With sws.Range(SRC_FIRST_CELL)
        
        Dim cOffset As Long: cOffset = RL_COLS_COUNT + RV_COL_OFFSET
        Dim fCell As Range: Set fCell = .Offset(, cOffset)
        Dim lCell As Range: Set lCell = fCell.End(xlToRight)
        
        scCount = lCell.Column - fCell.Column + 1 ' column labels
        cData = .Offset(, cOffset).Resize(CL_ROWS_COUNT, scCount).Value
        
        Dim rOffset As Long: rOffset = CL_ROWS_COUNT + CV_ROW_OFFSET
        
        With .Resize(, cOffset + scCount).Offset(rOffset)
            Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , xlByRows, xlPrevious)
            srCount = lCell.Row - .Row + 1
            With .Resize(srCount)
                rData = .Resize(, RL_COLS_COUNT).Value ' row labels
                vData = .Resize(, scCount).Offset(, cOffset).Value ' values
            End With
        End With
    
    End With
   
    ' Modify: Write the values transformed from the source arrays
    ' to the destination array.
   
    Dim drCount As Long: drCount = srCount * scCount
    Dim dcCount As Long: dcCount = CL_ROWS_COUNT + RL_COLS_COUNT + 1
   
    Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
   
    Dim sr As Long, sc As Long, n As Long, dr As Long, dc As Long
   
    For sr = 1 To srCount
        
        For sc = 1 To scCount
            
            ' Row Labels: Blank Check
            For n = 1 To RL_COLS_COUNT
                If Len(rData(sr, n)) > 0 Then Exit For
            Next n
            If n > RL_COLS_COUNT Then Exit For
            
            ' The Order
            
            dr = dr + 1
            dc = 0
            
            ' Row Labels
            For n = 1 To RL_COLS_COUNT
                dc = dc + 1
                dData(dr, dc) = rData(sr, n)
            Next n
            ' Column Labels
            For n = 1 To CL_ROWS_COUNT
                dc = dc + 1
                dData(dr, dc) = cData(n, sc)
            Next n
            ' Values
            dc = dc + 1
            dData(dr, dc) = vData(sr, sc)
        
        Next sc
    
    Next sr
   
    ' Write: write the values from the destination array
    ' to the destination range.
   
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    If dws.FilterMode Then dws.ShowAllData
    
    With dws.Range(DST_FIRST_CELL).Resize(dr, dcCount)
        .Value = dData
        .Resize(.Worksheet.Rows.Count - .Row - dr + 1).Offset(dr).Clear
   End With
   
   ' Inform.
   
   MsgBox "Data unpivoted.", vbInformation

End Sub