Creating a pupil scorecard from raw data

[chandelirious]

Hi, I wonder if you can help me.

I have an Excel spreadsheet that contains pupil records.

The pupils all have different amounts of subjects, so I can't say that the first ten rows are for pupil A, the next ten rows are for pupil B, etc. Each pupil takes up a different amount of rows.

What I would like to do is be able to produce a report card that is generated when inputting the pupil's registration number.

Here's some dummy data, set out the way I have it:

Pupil Number​	Forename​	Surname​	Class​	Subject​	Target Level​	Current Level​	Progress​	Attitude​	Term​
12345​	Chandler​	Bing​	1​	English​	3​	2​	Good​	1​	1​
12345​	Chandler​	Bing​	1​	Science​	3​	2​	Good​	1​	1​
12345​	Chandler​	Bing​	1​	Maths​	3​	2​	Fair​	1​	1​
12345​	Chandler​	Bing​	1​	Geography​	3​	1​	Fair​	1​	1​
12345​	Chandler​	Bing​	1​	History​	3​	2​	Excellent​	1​	1​
67890​	Monica​	Gellar​	1​	English​	2​	2​	Good​	1​	2​
67890​	Monica​	Gellar​	1​	Science​	2​	2​	Good​	1​	2​
67890​	Monica​	Gellar​	1​	Maths​	2​	2​	Fair​	1​	2​
67890​	Monica​	Gellar​	1​	Geography​	2​	2​	Fair​	1​	2​
67890​	Monica​	Gellar​	1​	History​	3​	1​	Excellent​	2​	2​
67890​	Monica​	Gellar​	1​	Reading​	3​	1​	Good​	2​	2​
67890​	Monica​	Gellar​	1​	French​	3​	3​	Good​	2​	2​
67890​	Monica​	Gellar​	1​	German​	1​	1​	Fair​	1​	2​
67890​	Monica​	Gellar​	1​	ICT​	2​	2​	Fair​	1​	2​
67890​	Monica​	Gellar​	1​	Metalwork​	1​	1​	Excellent​	1​	2​
67890​	Monica​	Gellar​	1​	PE​	3​	0​	Bad​	3​	2​
67890​	Monica​	Gellar​	1​	English​	4​	4​	Fair​	4​	3​
67890​	Monica​	Gellar​	1​	Science​	4​	4​	Excellent​	4​	3​
67890​	Monica​	Gellar​	1​	Maths​	4​	4​	Good​	4​	3​
67890​	Monica​	Gellar​	1​	Geography​	4​	3​	Good​	4​	3​
67890​	Monica​	Gellar​	1​	History​					3​
67890​	Monica​	Gellar​	1​	Reading​	4​	1​	Fair​	1​	3​
67890​	Monica​	Gellar​	1​	French​	4​	2​	Excellent​	1​	3​
67890​	Monica​	Gellar​	1​	German​	4​	4​	Bad​	2​	3​
67890​	Monica​	Gellar​	1​	ICT​	3​	5​	Excellent​	4​	3​
67890​	Monica​	Gellar​	1​	Metalwork​	3​	5​	Good​	2​	3​
67890​	Monica​	Gellar​	1​	PE​	3​	1​	Excellent​	4​	3​

The score card would need to have a header, a series of cells that displays relevant personal information - forename, surname, class, etc.

Then, I would like a series of columns that look to the data and presents it based on Subject, Target Level, Current Progress and Attitude.

BUT!

Here's the difficult part - I'd like different terms listed side-by-side.

See example below for how I'd like the scorecard to look:

Pupil Number

Forename

Surname

Class

Term 1

Term 2

Term 3

Subject

Target Level

Current Level

Progress

Attitude

Subject

Target Level

Current Level

Progress

Attitude

Subject

Target Level

Current Level

Progress

Attitude

So data from the columns would have to be spread across the whole table, and not end up all listed under Term 1.

Any ideas?

Thank you so much in advance!

 

[mumps]

I would love to be able to see pupil number, name and class displayed on the scorecard

I don't understand why you are not getting this data. This is what I'm getting when I run the macro:

chandelirious.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Pupil Number	Forename	Surname	Class
2	12345	Chandler	Bing	1
3
4	Term 1					Term 2					Term 3
5	Subject	Target Level	Current Level	Progress	Attitude	Subject	Target Level	Current Level	Progress	Attitude	Subject	Target Level	Current Level	Progress	Attitude
6	Maths	3	2	Fair	1	English	3	2	Good	1	Science	3	2	Good	1
7	History	3	2	Excellent	1	Geography	3	1	Fair	1
Chandler Bing

I've modified the macro to return the Records to their original order.

Sub CreateReports()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, dic As Object, dic2 As Object, i As Long, arr1 As Variant
    Dim term As Range, k As Variant, x As Long, y As Long: y = 1
    Set srcWS = Sheets("Records")
    With srcWS
        If .AutoFilterMode Then .AutoFilterMode = False
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A2:J" & LastRow).Replace ChrW(8203), ""
        arr = .Range("A2:A" & LastRow).Resize(, 10).Value
        .Cells(1, 1).CurrentRegion.Cells.Sort Key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr, 1)
        If Not dic.Exists(arr(i, 1)) Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = arr(i, 2) & " " & arr(i, 3)
            Set desWS = ActiveSheet
            Range("A1:D1").Value = Array("Pupil Number", "Forename", "Surname", "Class")
            Range("A2:D2").Value = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4))
            dic.Add arr(i, 1), Nothing
            With srcWS
                .Range("A1").AutoFilter
                .Range("A1").CurrentRegion.AutoFilter 1, arr(i, 1)
                For Each term In srcWS.Range("J2:J" & LastRow).SpecialCells(xlCellTypeVisible)
                    If Not dic2.Exists(term.Value) Then
                        dic2.Add term.Value, Nothing
                        desWS.Cells(4, y) = "Term " & y
                    End If
                Next term
                For Each k In dic2.keys
                    .Range("A1").CurrentRegion.AutoFilter 10, k
                    For x = 1 To dic2.Count Step 6
                        With desWS
                            .Cells(4, y) = "Term " & k
                            .Cells(.Rows.Count, y).End(xlUp).Offset(1).Resize(, 5).Value = Array("Subject", "Target Level", "Current Level", "Progress", "Attitude")
                            srcWS.Range("E2:I" & LastRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, y).End(xlUp).Offset(1)
                            y = y + 5
                        End With
                    Next x
                Next k
                dic2.RemoveAll
            End With
        End If
        y = 1
        desWS.Columns.AutoFit
    Next i
    With srcWS
        .Range("A1").AutoFilter
        .Cells(1, 1).CurrentRegion.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    End With
    Application.ScreenUpdating = True
End Sub

 

[chandelirious]

Ah that's worked!

That's absolutely fantastic, thank you so much!!

 

[mumps]

You are vey welcome.