Retrieve Column Headers Dynamically - Based on column Values

Hi, Try this code

Sub DataTransposition()

    Dim Arr, NewArr(), C1 As Integer, C2 As Integer, I As Byte, LR As Integer, Coll As Collection: Set Coll = New Collection
    
    Range("A4").End(xlDown).Offset(3).CurrentRegion.ClearContents
    
    Arr = Range(Cells(4, 1), Cells(Range("A4").End(xlDown).Row, Range("A4").End(xlToRight).Column))
    
    For C1 = LBound(Arr) + 1 To UBound(Arr)
        I = 1
        For C2 = LBound(Arr, 2) + 1 To UBound(Arr, 2)
            If Arr(C1, C2) <> 0 Then
                ReDim Preserve NewArr(I)
                NewArr(0) = Arr(C1, 1)
                NewArr(I) = Arr(1, C2) & ":" & Format(Arr(C1, C2), "0.00%")
                I = I + 1
            End If
        Next C2
        Coll.Add Join(NewArr, "|")
    Next C1
    
    LR = Cells(Rows.Count, 1).End(xlUp).Row + 1: ReDim NewArr(0): I = 1
    
    For C1 = 1 To Coll.Count
        I = I + 1
        NewArr(0) = VBA.Split(Coll(C1), "|")
        For C2 = 0 To UBound(NewArr(0))
            Cells(LR + I, C2 + 1).Value = NewArr(0)(C2)
        Next C2
    Next C1
    
End Sub

Please see the file attached.