Sub blah()
Set myRange = Selection
Set SceSht = Selection.Parent
Set NewSht = Sheets.Add
Set Destn = NewSht.Range("A2")
For Each rw In myRange.Rows
  If Application.CountBlank(rw) < rw.Cells.Count Then
    Destn.Value = SceSht.Cells(rw.Row, 3).Value
    Set Destn = Destn.Offset(1)
    For Each cll In rw.Cells
      If Len(cll.Value) > 0 Then
        Destn.Value = SceSht.Cells(3, cll.Column).Value
        cll.Copy Destn.Offset(, 1) 'this also copies comments but you can remove them en masse later.
        Destn.Offset(, 2).Value = cll.Comment.Text
        Set Destn = Destn.Offset(1)
      End If
    Next cll
  End If
Next rw
End Sub