I think that this works...

Option Explicit
Sub testme01()

   Dim curWks As Worksheet
   Dim newWks As Worksheet
   Dim iRow As Long
   Dim iCol As Long
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim oRow As Long
   
   Set curWks = Worksheets("sheet1")
   Set newWks = Worksheets.Add
   
   newWks.Range("A1").Resize(1, 4).Value _
       = Array("Admin", "Cycle (Red/Blue)", "Day", "Room")
   oRow = 1
   
   With curWks
       FirstRow = 2
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
       
       For iRow = FirstRow To LastRow
           For iCol = 2 To 11
               If IsEmpty(.Cells(iRow, iCol)) Then
                   'do nothing
               Else
                   oRow = oRow + 1
                   newWks.Cells(oRow, "A").Value = .Cells(iRow, "A").Value
                   newWks.Cells(oRow, "B").Value _
                                         = Left(.Cells(1, iCol).Value, 3)
                   newWks.Cells(oRow, "C").Value = Mid(.Cells(1, iCol), 4)
                   newWks.Cells(oRow, "D").Value = .Cells(iRow, iCol).Value
               End If
           Next iCol
       Next iRow
   End With
   
End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm