Insert Each Cell in Header Row as An Individual Column BEFORE the data the header is above

Question

I have an excel workbook where I need to take the header information, and insert it as a column. My current set-up looks like this (except with data spanning much further to the right and down)

And I need a macro that will format the data to look like this:

Is something like this possible with Excel 2013 VBA?

EDIT
I am not trying to transpose the header row. I am trying to insert a blank column before the header and write the value to the newly inserted column.

Answer 1

this will do

Sub Macro2()
Dim c As Integer, i As Integer
Dim myheader As String

c = range("b2").End(xlToRight).Column
For i = 1 To c
    Columns(2 * i + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    myheader = Cells(1, 2 * i).Value
    Cells(2, 2 * i + 1).Value = myheader
    Cells(2, 2 * i + 1).Select
    Selection.AutoFill destination:=range(Selection, Selection.Offset(0, -1).End(xlDown).Offset(0, 1))


Next i

End Sub

EDIT:

Sub Macro2()
Dim c As Integer, i As Integer
Dim myheader As String

c = range("b2").End(xlToRight).Column
For i = 1 To c
    Columns(2 * i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    myheader = Cells(1, 2 * i + 1).Value
    Cells(2, 2 * i).Value = myheader
    Cells(2, 2 * i).Select
    Selection.AutoFill destination:=range(Selection, Selection.Offset(0, -1).End(xlDown).Offset(0, 1))
Next i

End Sub