Transpose Multiple Columns to one Row with Unique Identifier

Try

Sub test()
    Dim a(), b(), i As Long, ii As Long, n As Long
    With Range("a1").CurrentRegion
        a = .Value
        ReDim b(1 To Application.CountA(.Cells), 1 To 2)
        For i = 2 To UBound(a, 1)
            For ii = 2 To UBound(a, 2)
                If a(i, ii) <> "" Then
                    n = n + 1
                    b(n, 1) = a(i, 1)
                    b(n, 2) = a(i, ii)
                End If
        Next ii, i
        With .Offset(, .Columns.Count + 1).Resize(, 2)
            .Rows(1).Value = [{"ID","Category"}]
            .Offset(1).Resize(n).Value = b
        End With
    End With
End Sub

Sample.xlsm