Create Pivot Tables for a list of Students

Hello All,
I am using Excel 2010 and have the following problem. Attached file is given to show my problem.
I use excel for testing my students.
I have 5 Sheets as shown below and two Names Ranges viz Student and Questions
1) Students – this list the name of students
2) PivotData – This is the Question I use for Testing.
3) PivotOriginal – This is the format of Pivot Table I wish to have for each Student.
4) SummaryPivot – This is the master for creating the Summary Report for all the Students.
5) SummaryReport – This is the Pivot created from SummaryPivot Sheet.

At present I am creating separate Sheets for each Student and create a Pivot Table for each one of them.

For eg. I have created Student1 and PTStudent1. Similarly I would create Student2 and PTStudent2 and so on…The list of Students is big.

I use the following Macro to create separate sheet for each student name.

Sub CreateSheetsFromAList()
Dim strCol As String
Dim strRow As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim strWsName As String
Dim strSrcName As String
On Error GoTo ErrHnd
'setup column letter and first row number containing names
'column
strCol = "A"
'row (number is in double quotes)
strRow = "1"
'turn off screen updating to stop flicker & increase speed
Application.ScreenUpdating = False

'save this worksheet's name, so we can go back to it later
strSrcName = ActiveSheet.Name
'set start of data in selected column
Set rngStart = ActiveSheet.Range(strCol & strRow)
'find end of data in selected column
Set rngEnd = ActiveSheet.Range(strCol & CStr(Application.Rows.Count)) _
.End(xlUp)
'loop through cells in used range
For Each rngCell In ActiveSheet.Range(rngStart, rngEnd)
'ignore empty cells in range
If rngCell.Text <> "" Then
'get worksheet name
strWsName = rngCell.Text
'test if worksheet exists
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist
'reinstate error handling
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
Else
'worksheet already exists
'reinstate error handling
On Error GoTo ErrHnd
End If

After creating Student Sheets and Pivot for each Student, I put the Student Name in SummaryReport Sheet from B2 onwards with their respective scores in G2 onwards.

Then I create the SummaryPivot from SummaryReport Sheet.

This process is very very time consuming.

Can I get the above macro to be modified (or a new one) which would:

1)Create individual sheets from the Range Name Student and paste the Range Name Questions on each of the individual Student Sheet

2)Then Create Pivot Report for each student (eg PTStudent1 Pivot Data Source would be Student1 Sheet, PTStudent2 Data Source would be Student2 ….and so on), and possibly have the same Sheet Tab Color for the sheet and its respective Pivot Table ( I have used Red for Student1).

3)Create a SummaryReport Sheet for all the Students with their respective names in Col B and their achieved scores in Col G. I think once the names of Students are populated in Col B on SummaryReport then I can use the INDIRECT function to get their respective scores?
Can anyone help with this please?

TIA

Rashid Khan

Hello
Thanks for the reply.
But I am just copy pasting the code I got from the web.

Sub CreateSheetsFromAList()
Dim strCol As String
Dim strRow As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim strWsName As String
Dim strSrcName As String

On Error GoTo ErrHnd

'setup column letter and first row number containing names
'column
strCol = "A"
'row (number is in double quotes)
strRow = "1"

'turn off screen updating to stop flicker & increase speed
Application.ScreenUpdating = False

'save this worksheet's name, so we can go back to it later
strSrcName = ActiveSheet.Name

'set start of data in selected column
Set rngStart = ActiveSheet.Range(strCol & strRow)
'find end of data in selected column
Set rngEnd = ActiveSheet.Range(strCol & CStr(Application.Rows.Count)) _
.End(xlUp)

'loop through cells in used range
For Each rngCell In ActiveSheet.Range(rngStart, rngEnd)
'ignore empty cells in range
If rngCell.Text <> "" Then
'get worksheet name
strWsName = rngCell.Text
'test if worksheet exists
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist
'reinstate error handling
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
Else
'worksheet already exists
'reinstate error handling
On Error GoTo ErrHnd
End If
End If
Next rngCell

'go back to the source worksheet
Worksheets(strSrcName).Activate

'reinstate screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear

'go back to the source worksheet
Worksheets(strSrcName).Activate

'reinstate screen updating
Application.ScreenUpdating = True
End Sub

Hope this would be easier.
Regards
Rashid Khan