: I have an Excel file which look like this:
:
: student 1 Eng A
: student 1 Math B
: Student 1 Hist B
: Student 1 Geog C
: Student 2 Eng D
: Student 2 Math C
: Student 2 chem D
:
: I would like to convert it into the following format:
:
: Eng Math Hist Geog Chem
: student 1 A B B C
: student 2 D C D
:
: Can any it be done in VBA?
:
:
this code assumes that the student name,class,grade are stored in separate cells - if in a single cell then you need to parse for each value
the student data should be in "Sheet1" and outputs result to "Sheet2"
note- change the [maxRows] constant to the max rows in your worksheet
Type Student
Name As String
Engl As String
Math As String
Hist As String
Geog As String
Chem As String
End Type
'** max rows of students **
'** CHANGE to no. of rows **
Const maxRows = 7
'***************************
Dim mStudents(1 To maxRows) As Student
Dim mNames(1 To maxRows) As String
Sub Macro1()
'
' Keyboard Shortcut: Ctrl+b
'
Dim row As Integer
Dim col As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim txt As String
Dim sNames As String
Dim sClass As String
Dim sGrade As String
Dim ArrayIdx As Integer
Set wb = Application.ActiveWorkbook
Set ws = wb.ActiveSheet
'loop thru rows
For row = 1 To maxRows
'get cell values
sNames = Trim(UCase(ws.Rows.Cells(row, 1)))
sClass = Trim(UCase(ws.Rows.Cells(row, 2)))
sGrade = Trim(UCase(ws.Rows.Cells(row, 3)))
'store students data in array
For ArrayIdx = 1 To maxRows
mStudents(row).Name = sNames
Select Case sClass
Case "ENG": mStudents(row).Engl = sGrade
Case "MATH": mStudents(row).Math = sGrade
Case "HIST": mStudents(row).Hist = sGrade
Case "GEOG": mStudents(row).Geog = sGrade
Case "CHEM": mStudents(row).Chem = sGrade
End Select
Next ArrayIdx
Next row
Set ws = Nothing
Set wb = Nothing
UniqueNames
PutWorksheet
End Sub
Sub PutWorksheet()
Dim row As Integer
Dim col As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim txt As String
Set wb = Application.ActiveWorkbook
Set ws = wb.Sheets("Sheet2")
'column titles
ws.Rows.Cells(1, 1) = "STUDENT"
ws.Rows.Cells(1, 2) = "ENGL"
ws.Rows.Cells(1, 3) = "MATH"
ws.Rows.Cells(1, 4) = "HIST"
ws.Rows.Cells(1, 5) = "GEOG"
ws.Rows.Cells(1, 6) = "CHEM"
'put names in new worksheet
For row = 1 To maxRows
ws.Rows.Cells(row + 1, 1) = mNames(row)
Next row
'put grades next to student names
Dim myRow As Integer
For row = 1 To maxRows
For myRow = 1 To maxRows
If mStudents(row).Name = ws.Rows.Cells(myRow + 1, 1) Then
If mStudents(row).Engl <> "" Then ws.Rows.Cells(myRow + 1, 2) = mStudents(row).Engl
If mStudents(row).Math <> "" Then ws.Rows.Cells(myRow + 1, 3) = mStudents(row).Math
If mStudents(row).Hist <> "" Then ws.Rows.Cells(myRow + 1, 4) = mStudents(row).Hist
If mStudents(row).Geog <> "" Then ws.Rows.Cells(myRow + 1, 5) = mStudents(row).Geog
If mStudents(row).Chem <> "" Then ws.Rows.Cells(myRow + 1, 6) = mStudents(row).Chem
End If
Next myRow
Next row
Set ws = Nothing
Set wb = Nothing
End Sub
Sub UniqueNames()
Dim i As Integer
Dim j As Integer
Dim Name1 As String
Dim Name2 As String
Name1 = ""
j = 0
For i = 1 To maxRows
Name2 = mStudents(i).Name
'put unique names into array
If Name1 <> Name2 Then
j = j + 1
mNames(j) = Name2
Name1 = Name2
End If
Next i
End Sub
