Sub blah()
Set SourceSht = ActiveSheet
Set newsht = Sheets.Add(After:=Sheets(Sheets.Count))
LastRow = SourceSht.Cells(SourceSht.Rows.Count, "B").End(xlUp).Row
With SourceSht.Cells(1).Resize(LastRow)
Set Headers = .SpecialCells(xlCellTypeConstants, 23)
Headers.Copy
newsht.Cells(1).PasteSpecial Transpose:=True
colm = 1
For Each cll In Headers.Cells
ofst = 1
Do Until Len(Application.Trim(cll.Offset(ofst).Value)) > 0 Or cll.Offset(ofst).Row > LastRow
ofst = ofst + 1
Loop
Range(cll, cll.Offset(ofst - 1)).Offset(, 1).Copy newsht.Cells(2, colm)
colm = colm + 1
Next cll
End With
End Sub