Paste Transpose while the first 2 columns will constant? Using VBA or Power Query

select your input data and bring it into powerquery using Data .. from table/range ... and uncheck [x] my data has headers (If you are reading in a file instead of referring to an input range, load that file instead, and then proceed:)

Use drop down atop the second column to [ ] uncheck the (null) item, thus filtering out those rows. Make sure formula contains <> null instead of something like ="xxx", otherwise replace that part of the code

Click select the first two columns, right click, unpivot other columns

Right click and remove the attribute column

File... Close and load to a pivot table report

Set up the pivot table properly as per below and you should be good to go

Sample powerquery code:

let Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Filtered Rows" = Table.SelectRows(Source , each ([Column2] <> null)),
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Filtered Rows", {"Column1", "Column2"}, "Attribute", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Attribute"})
in #"Removed Columns"

Pivot Table setup:

Transpose (Unpivot) Data (VBA)

Option Explicit

Sub TransposeData()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sCol As Long = 2
    Const sCriterion As String = "Sub-Catg."
    ' Destination
    Const dName As String = "Sheet2"
    Const dfCellAddress As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim surg As Range: Set surg = sws.UsedRange
    Dim scrCount As Long
    scrCount = Application.CountIf(surg.Columns(sCol), sCriterion)
    If scrCount = 0 Then Exit Sub ' no criterion found
    Dim scCount As Long: scCount = surg.Columns.Count
    If scCount <= sCol Then Exit Sub ' no data after criteria column
    Dim sData As Variant: sData = surg.Value
    
    ' Destination
    ' 'drCount' is actually the maximum possible number of rows.
    ' The result will probably have fewer ('dr').
    Dim drCount As Long: drCount = scrCount * (scCount - sCol)
    Dim dcCount As Long: dcCount = sCol + 1
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    Dim dr As Long: dr = 1
    
    Dim sValue As Variant
    Dim sr As Long
    Dim sc As Long
    Dim cdr As Long
    Dim dc As Long
    
    ' Write to destination array ('dData')
    For sr = 1 To UBound(sData, 1)
        If CStr(sData(sr, sCol)) = sCriterion Then ' criterion found
            cdr = dr
            ' Write after criterion.
            ' Looping until the last column allows blanks in-between
            ' at the cost of the code being a little slower.
            For sc = sCol + 1 To scCount
                If Len(CStr(sData(sr, sc))) > 0 Then
                    dData(dr, dcCount) = sData(sr, sc)
                    dr = dr + 1
                End If
            Next sc
            If dr > cdr Then ' values after criterion found
                ' Write criterion and before.
                For sc = 1 To sCol
                    dData(cdr, sc) = sData(sr, sc)
                Next sc
            'Else ' no value after criterion found
            End If
        'Else ' criterion not found
        End If
    Next sr
    
    If dr = 1 Then Exit Sub ' no values found
    dr = dr - 1
     
    ' Write to destination range.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dfCellAddress).Resize(, dcCount)
        ' Write to range.
        .Resize(dr).Value = dData
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - dr + 1).Offset(dr).Clear
    End With

    MsgBox "Data transposed.", vbInformation

End Sub