Tabulate test scores - vba

Question

I am working on vba code and would like to do the following:
Read:
A B
1 John 100
2 Jill 90
3 John 95
4 Amy 82
Change to (in alphabetical order):
A B C
1 Amy 82
2 Jill 90
3 John 100 95
Ultimately i need it to display the student's name and all scores next to the name.
So far i have this:
Sub Combine()
Dim J As Integer
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim wrk1 As Worksheet
Dim r1, r2, r3, r4, r5, r6, r7, ra, rb, rc, rd, re, rf, rg As Range
Sheets("Sheet2").Select
Set r1 = Range("D:D")
Set r2 = Range("B:B")
Set r3 = Range("E:E")
Set r4 = Range("C:C")
Set r5 = Range("F:F")
Set r6 = Range("H:H")
Set r7 = Range("AX:AX")
Sheets("Sheet3").Select
Set ra = Range("D:D")
Set rb = Range("B:B")
Set rc = Range("E:E")
Set rd = Range("C:C")
Set re = Range("F:F")
Set rf = Range("H:H")
Set rg = Range("AX:AX")
Set wrk = Workbooks.Add
ActiveWorkbook.Sheets(2).Activate
r1.Copy Range("A1")
r2.Copy Range("B1")
r3.Copy Range("C1")
r4.Copy Range("D1")
r5.Copy Range("E1")
r6.Copy Range("F1")
r7.Copy Range("G1")
ActiveWorkbook.Sheets(3).Activate
ra.Copy Range("A1")
rb.Copy Range("B1")
rc.Copy Range("C1")
rd.Copy Range("D1")
re.Copy Range("E1")
rf.Copy Range("F1")
rg.Copy Range("G1")
On Error Resume Next
Sheets(1).Select
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A2").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A3").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Sheets(1).Select
Range("A1:AY100").Sort _
Key1:=Range("C1"), Key2:=Range("B1"), Header:=xlYes
Next
End Sub

Answer 1

I would create a pivot table for your case. It's easy to create, updates easily and good to maintain. However, here is some piece of code:
Sub pivotDataInColumns()
Dim sourceSheet As Excel.Worksheet
Dim destinationSheet As Excel.Worksheet
Dim sourceRow As Long
Dim destinationRow As Long
Dim matchRow As Long
Dim searchColumn As Excel.Range
Dim nameToFind As String
Dim lastColumn As Long
Application.ScreenUpdating = False
With ThisWorkbook
'Change Worksheet name to suit:
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set destinationSheet = ThisWorkbook.Worksheets.Add
End With
Set searchColumn = destinationSheet.Columns("A")
For sourceRow = 1 To getLastRow(sourceSheet.Columns("A"))
nameToFind = sourceSheet.Cells(sourceRow, "A").Value
destinationRow = getMatchRow(nameToFind, searchColumn)
If destinationRow = 0 Then
destinationRow = getLastRow(destinationSheet.Columns("A")) + 1
destinationSheet.Cells(destinationRow, "A").Value = sourceSheet.Cells(sourceRow, "A").Value
End If
lastColumn = getLastColumn(destinationSheet.Rows(destinationRow)) + 1
destinationSheet.Cells(destinationRow, lastColumn).Value2 = sourceSheet.Cells(sourceRow, "B").Value2
Next sourceRow
'Remove row 1 garbage and sort:
With destinationSheet
.Rows(1).Delete
.UsedRange.Sort Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo
End With
Application.ScreenUpdating = True
MsgBox "Data processed successfully.", vbInformation
End Sub
Private Function getMatchRow(searchValue As Variant, _
searchArray As Variant) As Long
'This function returns 0 if searchValue is not on searchArray.
Dim element As Long
On Error Resume Next
element = WorksheetFunction.Match(CDbl(searchValue), searchArray, 0)
If element = 0 Then element = WorksheetFunction.Match(CStr(searchValue), searchArray, 0)
getMatchRow = element
End Function
Private Function getLastRow(sourceRange As Excel.Range) As Long
Dim parentSheet As Excel.Worksheet
Dim lastRow As Long
Set parentSheet = sourceRange.Parent
With parentSheet
lastRow = .Cells(.Rows.Count, sourceRange.column).End(xlUp).row
End With
getLastRow = lastRow
End Function
Private Function getLastColumn(sourceRange As Excel.Range) As Long
Dim parentSheet As Excel.Worksheet
Dim lastColumn As Long
Set parentSheet = sourceRange.Parent
With parentSheet
lastColumn = .Cells(sourceRange.row, .Columns.Count).End(xlToLeft).column
End With
getLastColumn = lastColumn
End Function