Loop through Matrix table and store in new sheets of column table [duplicate]

Question

Matrix Table

Column Table

how to convert matrix(not multiple column) to column table in VBA Code?

Sub columntomatrix
Dim mS As Worksheet
Dim eS As Worksheet

Set mS = ThisWorkbook.Sheets("Matrix")
Set eS = ThisWorkbook.Sheets("Price Entry Book")

Dim Matrix() As String
Dim entryPrice() As String
Dim Product As Range
Dim PriceBook As Range
Set Product = Range("Product")
Set PriceBook = Range("PriceBookName")

With mS.Range("B2")
    .Formula = "=IFERROR(INDEX(ListPrice,
    MATCH(" & .Offset(0,-1).Address(False, True) & "&" & 
    .Offset(-1, 0).Address(True, False) & ",ProductKey,0)),"" N/A  "")"


Product.Copy
'offset(0,-1) = selected cells move to left 1 column'
.Offset(0, -1).PasteSpecial

PriceBook.Copy
'offset(-1,0) = selected cells move to up 1 row'
.Offset(-1, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True

With Range(.Offset(0, 0), .Offset(Product.Rows.Count - 2, PriceBook.Rows.Count - 2))
    .FillDown
    .FillRight
End with
End with
End Sub

got to convert this formula to all VBA code.In the same function column to matrix.now i using the formula way, i wish to convert to VBA Coding

Answer 1

Unpivot: By Columns, Values Before Headers

• Before running the code, adjust the values in the constants section.

The Code

Option Explicit

Sub unpivotData()
    
    ' Define constants.
    
    Const srcName As String = "Matrix"
    Const srcFirst As String = "B1" ' Including headers.
    Const lrCol As Variant = "B"
    Const cCount As Long = 7
    Const repCount As Long = 1
    
    Const tgtName As String = "Price Entry Book"
    Const tgtFirst As String = "A2" ' Excluding headers.
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Source Range ('rng').
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets(srcName)
    Dim lRow As Long
    lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
    Dim rCount As Long
    rCount = lRow - ws.Range(srcFirst).Row + 1
    Dim rng As Range
    Set rng = ws.Range(srcFirst).Resize(rCount, cCount)
    
    ' Write values from Source Range to Source Array ('Source').
    
    Dim Source As Variant
    Source = rng.Value
    
    ' Write values from Source Array to Target Array ('Target').
    
    Dim Target As Variant
    ReDim Target(1 To rCount * (cCount - repCount), 1 To repCount + 2)
    
    Dim cVal As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    
    For j = 1 + repCount To cCount
        For i = 2 To rCount
            cVal = Source(i, j)
            If Not IsError(cVal) Then
                If Not IsEmpty(cVal) And cVal <> "N/A" Then
                    k = k + 1
                    For l = 1 To repCount
                        Target(k, l) = Source(i, l)
                    Next l
                    Target(k, l) = cVal
                    Target(k, l + 1) = Source(1, j)
                End If
            End If
        Next i
    Next j
    If k = 0 Then Exit Sub
    
    ' Write values from Target Array to Target Range.
    
    Set ws = wb.Worksheets(tgtName)
    With ws.Range(tgtFirst).Resize(, repCount + 2)
        ' Clear contents below header row.
        .Resize(ws.Rows.Count - ws.Range(tgtFirst).Row + 1).ClearContents
        ' Write values.
        .Resize(k).Value = Target
    End With

    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"

End Sub