Create Headers and list values

I have attached a file of an example of something I trying to do. Been so long since I have used VBA I have been getting nowhere. Basically I have a column with headers, I want to pull one instance of the header then the corresponding rows in col A and B where col C is the same header. Any help would be greatly appreciated.

Delete 1st row then run the code.

Sub test()
    Dim x, e, temp, n As Long
    Columns("f:g").ClearContents
    With Cells(1).CurrentRegion.Offset(1)
        n = 1
        For Each e In Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & ",,,row(1:" & _
                        .Rows.Count & "))," & .Columns(3).Address & ")=1," & .Columns(3).Address & "))"), False, 0)
            temp = e: If Not IsNumeric(temp) Then temp = Chr(34) & temp & Chr(34)
            x = Filter(.Parent.Evaluate("transpose(if(" & .Columns(3).Address & "=" & temp & "," & _
                        .Columns(2).Address & "&""^""&" & .Columns(1).Address & "))"), False, 0)
            Cells(n, "f").Value = e
            Cells(n + 1, "f").Resize(UBound(x) + 1).Value = Application.Transpose(x)
            n = n + UBound(x) + 3
        Next
        Columns("f").TextToColumns DataType:=1, other:=True, OtherChar:="^"
    End With
End Sub

If that takes care of your original question, select Thread Tools from the menu link above and mark this thread as SOLVED.

No a pivot table is not desired here. The example I gave is pretty basic, the end product will have further calcs and what not. The sort was just for setting up the larger need.

Is there a limitation to the amount of columns I can have in 'x'? When I add more I get a type mismatch error.

here is a new file with how it actually looks and what I want to do. In the live data there seems to be something blocking while I get something close in the TEST file. Sheet1 is the macro output, desired is what i want to do.

Now you are asking completely different question.

Sub test()
    Dim a, e, s, i As Long, ii As Long, n As Long, x, w, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("report")
        a = .Range("a1", .Cells.SpecialCells(11)).Resize(, 15).Value
    End With
    x = Array(1, 2, 4, 6, 8, 10, 12)
    For i = 3 To UBound(a, 1)
        If a(i, 14) <> "" Then
            If Not dic.exists(a(i, 14)) Then
                Set dic(a(i, 14)) = CreateObject("Scripting.Dictionary")
                dic(a(i, 14)).CompareMode = 1
            End If
            If Not dic(a(i, 14)).exists(a(i, 15)) Then
                ReDim w(1 To UBound(x) + 1, 1 To 1)
            Else
                w = dic(a(i, 14))(a(i, 15))
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For ii = 0 To UBound(x): w(ii + 1, UBound(w, 2)) = a(i, x(ii)): Next
            dic(a(i, 14))(a(i, 15)) = w
        Else: Exit For
        End If
    Next
    With Sheets.Add
        For Each e In dic
            n = n + 1
            With .Cells(n, 1)
                .Value = e: .Font.Bold = True
            End With
            For Each s In dic(e)
                n = n + 2: .Cells(n, 1).Value = s
                n = n + 1
                .Cells(n, 1).Resize(UBound(dic(e)(s), 2), 7).Value = _
                Application.Transpose(dic(e)(s))
                n = n + UBound(dic(e)(s), 2)
            Next
        Next
    End With
End Sub

Sorry, there was an unknown extra. Appreciate the perfect the solution.