T4128_Tabular Transpose Using Formulas Within Arrays

https://excel-egy.com/forum/t4128
---------------------------------

Sub Tabular_Transpose_Using_Formulas_Inside_Arrays()
    Dim a, b, i As Long, j As Long, k As Long

    a = Sheets("Sheet1").Range("B2:E" & Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row).Value
    ReDim b(1 To UBound(a, 1) * 3, 1 To 5)
    k = 1

    For j = LBound(a, 2) + 1 To UBound(a, 2)
        For i = LBound(a, 1) To UBound(a, 1)
            If Not IsEmpty(a(i, j)) And i <> 1 Then
                b(k, 1) = a(i, 1)
                b(k, 2) = "=INDEX(Sheet2!$B$3:$B$26,MATCH(R" & k + 1 & ",Sheet2!$A$3:$A$26,0))"
                b(k, 3) = a(i, j)
                b(k, 4) = "=INDEX(Sheet2!$C$3:$C$26,MATCH(R" & k + 1 & ",Sheet2!$A$3:$A$26,0))"
                b(k, 5) = a(1, j)
                k = k + 1
            End If
        Next i
    Next j

    Application.ScreenUpdating = False
        With Sheets("Sheet1").Range("P1")
            .Resize(, UBound(b, 2)).Value = Array("Date", "F1", "Value", "F2", "Category")
            .Offset(1).Resize(k - 1, UBound(b, 2)).Value = b
        End With
    Application.ScreenUpdating = True
End Sub