Sub TransposeStudentData()Dim lngRec As Long
Dim LastRow As Long, NextRow As Long
Dim xlSheet As Worksheet, xlSheet2 As Worksheet
Dim sName As String
Set xlSheet = ActiveSheet
Set xlSheet2 = Worksheets.Add
With xlSheet2
.Cells(1, 1) = "STUDENT"
.Cells(1, 2) = "SUBJECT1"
.Cells(1, 3) = "SUBJECT2"
.Cells(1, 4) = "SUBJECT3"
.Cells(1, 5) = "SUBJECT4"
.Cells(1, 6) = "MOST LIKED SUBJECT"
.Cells(1, 7) = "EXPLANATION"
End With
With xlSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lngRec = 2 To LastRow Step 15
NextRow = xlSheet2.Cells(xlSheet2.Rows.Count, "A").End(xlUp).Row + 1
If lngRec = 2 Then
With xlSheet2
If xlSheet.Cells(lngRec + 3, 1) Like "Subject*" Then
.Cells(NextRow, 1) = xlSheet.Cells(lngRec + 1, 1) & _
Chr(32) & xlSheet.Cells(lngRec + 2, 1)
.Cells(NextRow, 2) = xlSheet.Cells(lngRec + 4, 1)
.Cells(NextRow, 3) = xlSheet.Cells(lngRec + 6, 1)
.Cells(NextRow, 4) = xlSheet.Cells(lngRec + 8, 1)
.Cells(NextRow, 5) = xlSheet.Cells(lngRec + 10, 1)
.Cells(NextRow, 6) = Replace(xlSheet.Cells(lngRec + 11, 1), "MOST LIKED ", "")
.Cells(NextRow, 7) = xlSheet.Cells(lngRec + 13, 1)
Else
.Cells(NextRow, 1) = xlSheet.Cells(lngRec + 1, 1) & _
Chr(32) & xlSheet.Cells(lngRec + 2, 1) & _
Chr(32) & xlSheet.Cells(lngRec + 3, 1)
.Cells(NextRow, 2) = xlSheet.Cells(lngRec + 5, 1)
.Cells(NextRow, 3) = xlSheet.Cells(lngRec + 7, 1)
.Cells(NextRow, 4) = xlSheet.Cells(lngRec + 9, 1)
.Cells(NextRow, 5) = xlSheet.Cells(lngRec + 11, 1)
.Cells(NextRow, 6) = Replace(xlSheet.Cells(lngRec + 12, 1), "MOST LIKED ", "")
.Cells(NextRow, 7) = xlSheet.Cells(lngRec + 14, 1)
End If
End With
Else
With xlSheet2
If xlSheet.Cells(lngRec + 2, 1) Like "Subject*" Then
.Cells(NextRow, 1) = xlSheet.Cells(lngRec, 1) & _
Chr(32) & xlSheet.Cells(lngRec + 1, 1)
.Cells(NextRow, 2) = xlSheet.Cells(lngRec + 3, 1)
.Cells(NextRow, 3) = xlSheet.Cells(lngRec + 5, 1)
.Cells(NextRow, 4) = xlSheet.Cells(lngRec + 7, 1)
.Cells(NextRow, 5) = xlSheet.Cells(lngRec + 9, 1)
.Cells(NextRow, 6) = Replace(xlSheet.Cells(lngRec + 10, 1), "MOST LIKED ", "")
.Cells(NextRow, 7) = xlSheet.Cells(lngRec + 12, 1)
Else
.Cells(NextRow, 1) = xlSheet.Cells(lngRec, 1) & _
Chr(32) & xlSheet.Cells(lngRec + 1, 1) & _
Chr(32) & xlSheet.Cells(lngRec + 2, 1)
.Cells(NextRow, 2) = xlSheet.Cells(lngRec + 4, 1)
.Cells(NextRow, 3) = xlSheet.Cells(lngRec + 6, 1)
.Cells(NextRow, 4) = xlSheet.Cells(lngRec + 8, 1)
.Cells(NextRow, 5) = xlSheet.Cells(lngRec + 10, 1)
.Cells(NextRow, 6) = Replace(xlSheet.Cells(lngRec + 11, 1), "MOST LIKED ", "")
.Cells(NextRow, 7) = xlSheet.Cells(lngRec + 13, 1)
End If
End With
End If
Next lngRec
End With
End Sub