Download the SA-2 bulk results file from the website.
Open the downloaded file in Excel
Press Alt + F11 (or Alt + Fn + F11 on some laptops) to open the VBA editor
In the editor, click Insert > Module.
Copy and paste the code provided below into the module window.
Run the code.
When prompted, enter the maximum marks for each subject you conducted during the SA-2 exam.
Sub DetectConvertAndCopyToNewSheetRounded()
Dim ws As Worksheet
Dim newSheet As Worksheet
Dim header As String
Dim i As Integer
Dim maxValue As Double
Dim max1Value As Double
Dim lastRow As Long
Dim cell As Range
Dim inputMaxValue As Variant
Dim inputMax1Value As Variant
Dim copyColumn As Integer
Dim multiplier As Double
' Set the active sheet
Set ws = ActiveSheet
' Create or activate the new sheet named "80marks SA1"
On Error Resume Next
Set newSheet = ThisWorkbook.Worksheets("80marks SA1")
On Error GoTo 0
If newSheet Is Nothing Then
Set newSheet = ThisWorkbook.Worksheets.Add
newSheet.Name = "80marks SA1"
Else
newSheet.Cells.Clear ' Clear existing content if the sheet already exists
End If
' Copy columns A to D from the original sheet to the new sheet
ws.Range("A:D").Copy Destination:=newSheet.Range("A1")
' Loop through the first 80 columns to check for "max" or "max1" in headers
copyColumn = 5 ' Start copying calculated columns to column E in the new sheet
For i = 1 To 80
header = LCase(Trim(ws.Cells(1, i).Value))
' Check if the column header contains "max" (but not "max1")
If InStr(header, "max") > 0 And InStr(header, "max1") = 0 Then
' Prompt for input max value for "max" columns
inputMaxValue = InputBox("Enter the desired max value for column '" & ws.Cells(1, i).Value & "':", "Enter Max Value", 80)
If inputMaxValue = "" Or Not IsNumeric(inputMaxValue) Then
MsgBox "Invalid input or operation canceled for column '" & ws.Cells(1, i).Value & "'.", vbExclamation
Exit Sub
End If
maxValue = CDbl(inputMaxValue)
' Determine multiplier based on user input:
' For 40: multiplier = 80/40 = 2 (same as marks*(8/4))
' For 50: multiplier = 80/50 = 1.6 (marks*(8/5))
' For 60: multiplier = 80/60 ≈ 1.33 (marks*(8/6))
' For 70: multiplier = 80/70 ≈ 1.14 (marks*(8/7))
' For 80: multiplier = 80/80 = 1 (marks*(8/8))
' For 25: multiplier = 4 (marks*4)
' For 20: multiplier = 5 (marks*5)
If maxValue = 25 Then
multiplier = 4
ElseIf maxValue = 20 Then
multiplier = 5
Else
multiplier = 80 / maxValue
End If
' Copy header from the original column to the new sheet
newSheet.Cells(1, copyColumn).Value = ws.Cells(1, i).Value
' Get the last row in the "max" column
lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
' Calculate and store the adjusted values, rounded to 1 decimal place
For Each cell In ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i))
If IsNumeric(cell.Value) And cell.Value > 0 Then
newSheet.Cells(cell.Row, copyColumn).Value = Round(cell.Value * multiplier, 1)
End If
Next cell
' Move to the next column in the new sheet
copyColumn = copyColumn + 1
' Check if the column header contains "max1"
ElseIf InStr(header, "max1") > 0 Then
' Prompt for input max1 value for "max1" columns
inputMax1Value = InputBox("Enter the desired max1 value for column '" & ws.Cells(1, i).Value & "':", "Enter Max1 Value", 100)
If inputMax1Value = "" Or Not IsNumeric(inputMax1Value) Then
MsgBox "Invalid input or operation canceled for column '" & ws.Cells(1, i).Value & "'.", vbExclamation
Exit Sub
End If
max1Value = CDbl(inputMax1Value)
' Determine multiplier based on user input for max1 value
If max1Value = 25 Then
multiplier = 4
ElseIf max1Value = 20 Then
multiplier = 5
Else
multiplier = 80 / max1Value
End If
' Copy header from the original column to the new sheet
newSheet.Cells(1, copyColumn).Value = ws.Cells(1, i).Value
' Get the last row in the "max1" column
lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
' Calculate and store the adjusted values, rounded to 1 decimal place
For Each cell In ws.Range(ws.Cells(2, i), ws.Cells(lastRow, i))
If IsNumeric(cell.Value) And cell.Value > 0 Then
newSheet.Cells(cell.Row, copyColumn).Value = Round(cell.Value * multiplier, 1)
End If
Next cell
' Move to the next column in the new sheet
copyColumn = copyColumn + 1
End If
Next i
' Sort the new sheet data based on the student names in column B (alphabetic order)
With newSheet
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
With .Sort
.SortFields.Clear
.SortFields.Add Key:=.Parent.Range("B2:B" & lastRow), Order:=xlAscending
.SetRange .Parent.Range("A1").CurrentRegion
.Header = xlYes
.Apply
End With
End With
MsgBox "Marks have been updated, copied to the new sheet '80marks SA1', and student names in column B are sorted alphabetically." & vbCrLf & "Calculated values are rounded to 1 decimal place.", vbInformation
End Sub
In step-2
Copy the code below and run it to round up the marks.
CSS Code Example
This is a sample CSS snippet
Styling elements
Modern design
Responsive layout
div {
color: red;
}
Sub RoundDecimals()
Dim ws As Worksheet
Dim cell As Range
Dim lastRow As Long, lastCol As Long
Dim decimalPart As Double
' Set the active sheet to ws
Set ws = ActiveSheet
' Find the last row and last column with data
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' Loop through each column and each row in the used range
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
' Check if the cell has a numeric value
If IsNumeric(cell.Value) Then
' Check if it has a decimal part
If cell.Value <> Int(cell.Value) Then
' Get the decimal part of the cell value
decimalPart = cell.Value - Int(cell.Value)
' Round down if less than 0.5, round up if 0.5 or more
If decimalPart < 0.5 Then
cell.Value = WorksheetFunction.RoundDown(cell.Value, 0)
Else
cell.Value = WorksheetFunction.RoundUp(cell.Value, 0)
End If
End If
End If
Next cell
MsgBox "Rounding process complete."
End Sub
In step-3
Copy the calculated marks of FA-3, FA-4, and SA-2 into a new sheet.
Then, copy and run the code below.
Sub CalculateSubjectScores()
Dim ws As Worksheet
Dim numSubjects As Integer
Dim i As Integer
Dim fa1Col As Range, fa2Col As Range, sa1Col As Range, resultCol As Range
Dim lastRow As Integer
Dim subjectTitle As String
' Set active worksheet
Set ws = ActiveSheet
' Ask for the number of subjects
numSubjects = Application.InputBox("Enter the number of subjects:", Type:=1)
If numSubjects <= 0 Then Exit Sub
' Loop through each subject to get column selections
For i = 1 To numSubjects
subjectTitle = Application.InputBox("Enter the subject title for Subject " & i & ":", Type:=2)
Application.StatusBar = "Select columns for " & subjectTitle
' Select FA1 column
On Error Resume Next
Set fa1Col = Application.InputBox("Select FA1 column for " & subjectTitle, Type:=8)
If fa1Col Is Nothing Then Exit Sub
' Select FA2 column
Set fa2Col = Application.InputBox("Select FA2 column for " & subjectTitle, Type:=8)
If fa2Col Is Nothing Then Exit Sub
' Select SA1 column
Set sa1Col = Application.InputBox("Select SA1 column for " & subjectTitle, Type:=8)
If sa1Col Is Nothing Then Exit Sub
' Select column for calculated data
Set resultCol = Application.InputBox("Select result column for " & subjectTitle, Type:=8)
If resultCol Is Nothing Then Exit Sub
' Set subject title in the result column header
ws.Cells(1, resultCol.Column).Value = subjectTitle & " Score"
' Find last row in FA1 column
lastRow = ws.Cells(ws.Rows.Count, fa1Col.Column).End(xlUp).Row
' Apply new formula: SA1 + FA1 + FA2
ws.Range(resultCol.Cells(2, 1), resultCol.Cells(lastRow, 1)).FormulaR1C1 = _
"=RC[" & (sa1Col.Column - resultCol.Column) & "] + RC[" & (fa1Col.Column - resultCol.Column) & "] + RC[" & (fa2Col.Column - resultCol.Column) & "]"
Next i
' Clear status bar and show completion message
Application.StatusBar = False
MsgBox "Calculation completed!", vbInformation
End Sub
In step 4
For class 1-3
Copy and run the code below to calculate T2 marks
(FA-1: 10 marks + FA-2: 10 marks + SA-2: 80 marks).
Option Explicit
Sub ProcessData()
Dim wsSource As Worksheet, wsSorted As Worksheet, wsOutput As Worksheet, wsRound As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim headerRow As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'---------------------------
' Step 1. Use the active sheet as the source data.
Set wsSource = ActiveSheet
'---------------------------
' Step 2. Ensure Sheet2 exists for sorted data.
On Error Resume Next
Set wsSorted = Worksheets("Sheet2")
If wsSorted Is Nothing Then
Set wsSorted = Worksheets.Add(After:=wsSource)
wsSorted.Name = "Sheet2"
Else
wsSorted.Cells.Clear
End If
'---------------------------
' Step 3. Ensure Sheet3 exists for final output.
Set wsOutput = Worksheets("Sheet3")
If wsOutput Is Nothing Then
Set wsOutput = Worksheets.Add(After:=wsSorted)
wsOutput.Name = "Sheet3"
Else
wsOutput.Cells.Clear
End If
On Error GoTo 0
'---------------------------
' Step 4. Delete empty Remark columns from wsSource.
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Set headerRow = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol))
For j = lastCol To 1 Step -1
If InStr(1, wsSource.Cells(1, j).Value, "Remark", vbTextCompare) > 0 Then
' Delete if only the header is nonblank.
If Application.WorksheetFunction.CountA(wsSource.Columns(j)) = 1 Then
wsSource.Columns(j).Delete
End If
End If
Next j
'---------------------------
' Step 5. Copy cleaned data to Sheet2 and sort by Student Name.
wsSource.UsedRange.Copy Destination:=wsSorted.Range("A1")
' Find the Student Name column.
lastCol = wsSorted.Cells(1, wsSorted.Columns.Count).End(xlToLeft).Column
Dim colStudentName As Long: colStudentName = 0
For j = 1 To lastCol
If InStr(1, wsSorted.Cells(1, j).Value, "Student Name", vbTextCompare) > 0 Then
colStudentName = j
Exit For
End If
Next j
If colStudentName > 0 Then
lastRow = wsSorted.Cells(wsSorted.Rows.Count, colStudentName).End(xlUp).Row
wsSorted.Range("A1").CurrentRegion.Sort Key1:=wsSorted.Cells(2, colStudentName), Order1:=xlAscending, Header:=xlYes
Else
MsgBox "Student Name column not found in Sheet2!", vbExclamation
GoTo CleanUp
End If
'---------------------------
' Step 6. Copy sorted data to Sheet3 for further processing.
wsSorted.UsedRange.Copy Destination:=wsOutput.Range("A1")
lastRow = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row
'---------------------------
' Step 7. (Removed Average Calculation)
' Instead of calculating any averages, we now use the subject columns as they appear.
' We assume that columns A to D are identifiers and that subjects start from column E.
'---------------------------
' Step 8. Append Overall Totals.
' First, determine the subject range: from column E (column 5) to the last column in wsOutput.
lastCol = wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Column
Dim subjectStart As Long, subjectEnd As Long, subjectCount As Long, maxTotalMarks As Long
subjectStart = 5
subjectEnd = lastCol
subjectCount = subjectEnd - 4 ' Excluding the first 4 identifier columns.
If subjectCount <= 0 Then
MsgBox "No subject columns found from column E onward.", vbCritical
GoTo CleanUp
End If
maxTotalMarks = subjectCount * 100 ' Assuming each subject is out of 100.
' Append Total Marks, Total Percentage, and Overall Grade columns.
Dim colTotalMarks As Long, colPercentage As Long, colOverallGrade As Long
colTotalMarks = lastCol + 1
wsOutput.Cells(1, colTotalMarks).Value = "Total Marks"
colPercentage = colTotalMarks + 1
wsOutput.Cells(1, colPercentage).Value = "Total Percentage"
colOverallGrade = colPercentage + 1
wsOutput.Cells(1, colOverallGrade).Value = "Overall Grade"
Dim totalMarks As Double, totalPercentage As Double
For i = 2 To lastRow
totalMarks = 0
For j = subjectStart To subjectEnd
totalMarks = totalMarks + Val(wsOutput.Cells(i, j).Value)
Next j
wsOutput.Cells(i, colTotalMarks).Value = totalMarks
totalPercentage = (totalMarks / maxTotalMarks) * 100
wsOutput.Cells(i, colPercentage).Value = Round(totalPercentage, 2)
wsOutput.Cells(i, colOverallGrade).Value = GetGrade(CustomRound(totalPercentage))
Next i
'---------------------------
' Step 9. Create Sheet4: First apply rounding to calculated columns, then insert Grade columns.
On Error Resume Next
Set wsRound = Worksheets("Sheet4")
If wsRound Is Nothing Then
Set wsRound = Worksheets.Add(After:=wsOutput)
wsRound.Name = "Sheet4"
Else
wsRound.Cells.Clear
End If
On Error GoTo 0
' Copy all data from Sheet3 to Sheet4.
wsOutput.UsedRange.Copy Destination:=wsRound.Range("A1")
lastRow = wsRound.Cells(wsRound.Rows.Count, 1).End(xlUp).Row
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
' First, apply the custom rounding on calculated columns.
Dim headerVal As String
For j = 1 To lastCol
headerVal = wsRound.Cells(1, j).Value
' Process columns with "Average" or "Total" (exclude any column already containing "Grade").
If (InStr(1, headerVal, "Average", vbTextCompare) > 0 Or _
InStr(1, headerVal, "Total", vbTextCompare) > 0) And _
(InStr(1, headerVal, "Grade", vbTextCompare) = 0) Then
For i = 2 To lastRow
If IsNumeric(wsRound.Cells(i, j).Value) Then
wsRound.Cells(i, j).Value = CustomRound(wsRound.Cells(i, j).Value)
End If
Next i
End If
Next j
' --- Recalculate Total Percentage and Overall Grade in Sheet4 based on Total Marks ---
Dim colTotalMarksS4 As Long, colPercS4 As Long, colGradeS4 As Long
For j = 1 To lastCol
Select Case wsRound.Cells(1, j).Value
Case "Total Marks": colTotalMarksS4 = j
Case "Total Percentage": colPercS4 = j
Case "Overall Grade": colGradeS4 = j
End Select
Next j
' Set maximum total marks based on subject count.
Dim maxTotal As Double: maxTotal = subjectCount * 100
If colTotalMarksS4 > 0 And colPercS4 > 0 And colGradeS4 > 0 Then
For i = 2 To lastRow
Dim totMarks As Double, perc As Double
totMarks = wsRound.Cells(i, colTotalMarksS4).Value
perc = (totMarks / maxTotal) * 100
wsRound.Cells(i, colPercS4).Value = CustomRound(perc)
wsRound.Cells(i, colGradeS4).Value = GetGrade(CustomRound(perc))
Next i
End If
' Now, insert Grade columns for each subject column.
' We assume that subject columns are from column E (5) to the subjectEnd.
' Loop backward from the last subject column to avoid shifting issues.
For j = subjectEnd To subjectStart Step -1
headerVal = wsRound.Cells(1, j).Value
' Exclude identifier columns.
If InStr(1, headerVal, "Roll Number", vbTextCompare) = 0 And _
InStr(1, headerVal, "Student Name", vbTextCompare) = 0 And _
InStr(1, headerVal, "Class", vbTextCompare) = 0 And _
InStr(1, headerVal, "Section", vbTextCompare) = 0 Then
wsRound.Columns(j + 1).Insert Shift:=xlToRight
wsRound.Cells(1, j + 1).Value = headerVal & " Grade"
For i = 2 To lastRow
Dim cellVal As Double
cellVal = Val(wsRound.Cells(i, j).Value)
wsRound.Cells(i, j + 1).Value = GetGrade(cellVal)
Next i
End If
Next j
CleanUp:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Processing complete!", vbInformation
End Sub
'---------------------------
' Helper function: Finds the column number where the header cell contains headerText.
Function FindColumn(ws As Worksheet, headerText As String) As Long
Dim lastCol As Long, j As Long
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
If InStr(1, ws.Cells(1, j).Value, headerText, vbTextCompare) > 0 Then
FindColumn = j
Exit Function
End If
Next j
FindColumn = 0
End Function
'---------------------------
' Grade scale function using your provided grading scale.
Function GetGrade(marks As Double) As String
Select Case marks
Case 91 To 100
GetGrade = "A+"
Case 81 To 90
GetGrade = "A"
Case 71 To 80
GetGrade = "B+"
Case 61 To 70
GetGrade = "B"
Case 51 To 60
GetGrade = "C+"
Case 41 To 50
GetGrade = "C"
Case 33 To 40
GetGrade = "D"
Case 0 To 32
GetGrade = "E"
Case Else
GetGrade = ""
End Select
End Function
'---------------------------
' Custom rounding function:
' If the fractional part is less than 0.5, return the integer part.
' If the fractional part is 0.5 or greater, return the integer part plus one.
Function CustomRound(val As Double) As Long
Dim intPart As Long, frac As Double
intPart = Fix(val)
frac = val - intPart
If frac >= 0.5 Then
CustomRound = intPart + 1
Else
CustomRound = intPart
End If
End Function
For class 4-5
Copy and run the code below to calculate T2 marks
(FA-1: 10 marks + FA-2: 10 marks + SA-2: 80 marks).
Option Explicit
Sub ProcessData()
Dim wsSource As Worksheet, wsSorted As Worksheet, wsOutput As Worksheet, wsRound As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim headerRow As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'---------------------------
' Step 1. Use the active sheet as the source data.
Set wsSource = ActiveSheet
'---------------------------
' Step 2. Ensure Sheet2 exists for sorted data.
On Error Resume Next
Set wsSorted = Worksheets("Sheet2")
If wsSorted Is Nothing Then
Set wsSorted = Worksheets.Add(After:=wsSource)
wsSorted.Name = "Sheet2"
Else
wsSorted.Cells.Clear
End If
'---------------------------
' Step 3. Ensure Sheet3 exists for final output (without grade columns).
Set wsOutput = Worksheets("Sheet3")
If wsOutput Is Nothing Then
Set wsOutput = Worksheets.Add(After:=wsSorted)
wsOutput.Name = "Sheet3"
Else
wsOutput.Cells.Clear
End If
On Error GoTo 0
'---------------------------
' Step 4. Delete empty Remark columns from wsSource.
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Set headerRow = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol))
For j = lastCol To 1 Step -1
If InStr(1, wsSource.Cells(1, j).Value, "Remark", vbTextCompare) > 0 Then
' Delete if only the header is nonblank.
If Application.WorksheetFunction.CountA(wsSource.Columns(j)) = 1 Then
wsSource.Columns(j).Delete
End If
End If
Next j
'---------------------------
' Step 5. Copy cleaned data to Sheet2 and sort by Student Name.
wsSource.UsedRange.Copy Destination:=wsSorted.Range("A1")
' Find the Student Name column.
lastCol = wsSorted.Cells(1, wsSorted.Columns.Count).End(xlToLeft).Column
Dim colStudentName As Long: colStudentName = 0
For j = 1 To lastCol
If InStr(1, wsSorted.Cells(1, j).Value, "Student Name", vbTextCompare) > 0 Then
colStudentName = j
Exit For
End If
Next j
If colStudentName > 0 Then
lastRow = wsSorted.Cells(wsSorted.Rows.Count, colStudentName).End(xlUp).Row
wsSorted.Range("A1").CurrentRegion.Sort Key1:=wsSorted.Cells(2, colStudentName), Order1:=xlAscending, Header:=xlYes
Else
MsgBox "Student Name column not found in Sheet2!", vbExclamation
GoTo CleanUp
End If
'---------------------------
' Step 6. Copy sorted data to Sheet3 for further processing.
wsSorted.UsedRange.Copy Destination:=wsOutput.Range("A1")
lastRow = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row
'---------------------------
' Step 7. Insert Calculated Column for English Average.
Dim english1Col As Long, english2Col As Long, colEnglishAvg As Long
english1Col = FindColumn(wsOutput, "English 1")
english2Col = FindColumn(wsOutput, "English 2")
If english1Col > 0 And english2Col > 0 Then
wsOutput.Columns(english2Col + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, english2Col + 1).Value = "English Average"
colEnglishAvg = english2Col + 1
For i = 2 To lastRow
wsOutput.Cells(i, colEnglishAvg).Value = CustomRound((Val(wsOutput.Cells(i, english1Col).Value) + _
Val(wsOutput.Cells(i, english2Col).Value)) / 2)
Next i
Else
Dim colEnglishAlt As Long
colEnglishAlt = FindColumn(wsOutput, "English")
If colEnglishAlt > 0 Then
wsOutput.Columns(colEnglishAlt + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colEnglishAlt + 1).Value = "English Average"
colEnglishAvg = colEnglishAlt + 1
For i = 2 To lastRow
wsOutput.Cells(i, colEnglishAvg).Value = CustomRound(Val(wsOutput.Cells(i, colEnglishAlt).Value))
Next i
Else
MsgBox "No English columns found.", vbCritical
GoTo CleanUp
End If
End If
'---------------------------
' Step 8. Append Overall Totals.
Dim colTotalMarks As Long, colPercentage As Long, colOverallGrade As Long
lastCol = wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Column
colTotalMarks = lastCol + 1
wsOutput.Cells(1, colTotalMarks).Value = "Total Marks"
colPercentage = colTotalMarks + 1
wsOutput.Cells(1, colPercentage).Value = "Total Percentage"
colOverallGrade = colPercentage + 1
wsOutput.Cells(1, colOverallGrade).Value = "Overall Grade"
Dim englishScore As Double, kannadaScore As Double, hindiScore As Double, mathsScore As Double
Dim socialScore As Double, scienceScore As Double, computerScore As Double
Dim gkScore As Double, moralScore As Double, drawingScore As Double
Dim totalMarks As Double, totalPercentage As Double
Dim subjectCount As Long, maxTotalMarks As Long
Dim colKannada As Long, colMaths As Long, colComputer As Long
Dim colHindi As Long, colGK As Long, colMoral As Long, colDrawing As Long
Dim colSocial As Long, colScience As Long
colKannada = FindColumn(wsOutput, "Kannada")
colHindi = FindColumn(wsOutput, "Hindi")
colMaths = FindColumn(wsOutput, "Maths")
colSocial = FindColumn(wsOutput, "Social")
colScience = FindColumn(wsOutput, "Science")
colComputer = FindColumn(wsOutput, "Computer")
colGK = FindColumn(wsOutput, "GK")
colMoral = FindColumn(wsOutput, "Moral")
colDrawing = FindColumn(wsOutput, "Drawing")
' Essential subjects check.
If colEnglishAvg = 0 Or colKannada = 0 Or colHindi = 0 Or colMaths = 0 Or _
colSocial = 0 Or colScience = 0 Or colComputer = 0 Or colGK = 0 Or _
colMoral = 0 Or colDrawing = 0 Then
MsgBox "One or more required subject columns (English, Kannada, Hindi, Maths, Social, Science, Computer, GK, Moral, Drawing) not found.", vbCritical
GoTo CleanUp
End If
' Count subjects (should be 10 subjects).
subjectCount = 10
maxTotalMarks = subjectCount * 100
For i = 2 To lastRow
englishScore = Val(wsOutput.Cells(i, colEnglishAvg).Value)
kannadaScore = Val(wsOutput.Cells(i, colKannada).Value)
hindiScore = Val(wsOutput.Cells(i, colHindi).Value)
mathsScore = Val(wsOutput.Cells(i, colMaths).Value)
socialScore = Val(wsOutput.Cells(i, colSocial).Value)
scienceScore = Val(wsOutput.Cells(i, colScience).Value)
computerScore = Val(wsOutput.Cells(i, colComputer).Value)
gkScore = Val(wsOutput.Cells(i, colGK).Value)
moralScore = Val(wsOutput.Cells(i, colMoral).Value)
drawingScore = Val(wsOutput.Cells(i, colDrawing).Value)
totalMarks = englishScore + kannadaScore + hindiScore + mathsScore + socialScore + scienceScore + computerScore + gkScore + moralScore + drawingScore
wsOutput.Cells(i, colTotalMarks).Value = totalMarks
totalPercentage = (totalMarks / maxTotalMarks) * 100
wsOutput.Cells(i, colPercentage).Value = Round(totalPercentage, 2)
wsOutput.Cells(i, colOverallGrade).Value = GetGrade(CustomRound(totalPercentage))
Next i
'---------------------------
' Step 9. Create Sheet4: First apply rounding to calculated columns, then insert Grade columns.
On Error Resume Next
Set wsRound = Worksheets("Sheet4")
If wsRound Is Nothing Then
Set wsRound = Worksheets.Add(After:=wsOutput)
wsRound.Name = "Sheet4"
Else
wsRound.Cells.Clear
End If
On Error GoTo 0
' Copy all data from Sheet3 to Sheet4.
wsOutput.UsedRange.Copy Destination:=wsRound.Range("A1")
lastRow = wsRound.Cells(wsRound.Rows.Count, 1).End(xlUp).Row
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
' First, apply the custom rounding on calculated columns.
Dim headerVal As String
For j = 1 To lastCol
headerVal = wsRound.Cells(1, j).Value
' Process columns with "Average" or "Total" (exclude any column already containing "Grade").
If (InStr(1, headerVal, "Average", vbTextCompare) > 0 Or _
InStr(1, headerVal, "Total", vbTextCompare) > 0) And _
(InStr(1, headerVal, "Grade", vbTextCompare) = 0) Then
For i = 2 To lastRow
If IsNumeric(wsRound.Cells(i, j).Value) Then
wsRound.Cells(i, j).Value = CustomRound(wsRound.Cells(i, j).Value)
End If
Next i
End If
Next j
' --- Recalculate Total Percentage and Overall Grade in Sheet4 based on Total Marks ---
Dim colTotalMarksS4 As Long, colPercS4 As Long, colGradeS4 As Long
For j = 1 To lastCol
Select Case wsRound.Cells(1, j).Value
Case "Total Marks": colTotalMarksS4 = j
Case "Total Percentage": colPercS4 = j
Case "Overall Grade": colGradeS4 = j
End Select
Next j
' Set maximum total marks to 1000 (10 subjects × 100 marks each).
Dim maxTotal As Double: maxTotal = 1000
If colTotalMarksS4 > 0 And colPercS4 > 0 And colGradeS4 > 0 Then
For i = 2 To lastRow
Dim totMarks As Double, perc As Double
totMarks = wsRound.Cells(i, colTotalMarksS4).Value
perc = (totMarks / maxTotal) * 100
wsRound.Cells(i, colPercS4).Value = CustomRound(perc)
wsRound.Cells(i, colGradeS4).Value = GetGrade(CustomRound(perc))
Next i
End If
' Now, insert Grade columns for each calculated subject column.
' Define the keywords to determine which columns get a grade column.
Dim keywords As Variant
keywords = Array("English", "Kannada", "Hindi", "Social", "Science", _
"Maths", "Computer", "GK", "Moral", "Drawing", "Average", "Total")
' Loop backward from the last column to avoid shifting issues.
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
For j = lastCol To 1 Step -1
headerVal = wsRound.Cells(1, j).Value
' Exclude identifier columns.
If InStr(1, headerVal, "Total", vbTextCompare) = 0 And _
InStr(1, headerVal, "Roll Number", vbTextCompare) = 0 And _
InStr(1, headerVal, "Student Name", vbTextCompare) = 0 And _
InStr(1, headerVal, "Class", vbTextCompare) = 0 And _
InStr(1, headerVal, "Section", vbTextCompare) = 0 And _
InStr(1, headerVal, "Grade", vbTextCompare) = 0 Then
Dim qualifies As Boolean: qualifies = False
Dim k As Integer
For k = LBound(keywords) To UBound(keywords)
If InStr(1, headerVal, keywords(k), vbTextCompare) > 0 Then
qualifies = True
Exit For
End If
Next k
If qualifies Then
wsRound.Columns(j + 1).Insert Shift:=xlToRight
wsRound.Cells(1, j + 1).Value = headerVal & " Grade"
For i = 2 To lastRow
Dim cellVal As Double
cellVal = Val(wsRound.Cells(i, j).Value)
wsRound.Cells(i, j + 1).Value = GetGrade(cellVal)
Next i
End If
End If
Next j
CleanUp:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Processing complete!", vbInformation
End Sub
'---------------------------
' Helper function: Finds the column number where the header cell contains headerText.
Function FindColumn(ws As Worksheet, headerText As String) As Long
Dim lastCol As Long, j As Long
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
If InStr(1, ws.Cells(1, j).Value, headerText, vbTextCompare) > 0 Then
FindColumn = j
Exit Function
End If
Next j
FindColumn = 0
End Function
'---------------------------
' Grade scale function using your provided grading scale.
Function GetGrade(marks As Double) As String
Select Case marks
Case 91 To 100
GetGrade = "A+"
Case 81 To 90
GetGrade = "A"
Case 71 To 80
GetGrade = "B+"
Case 61 To 70
GetGrade = "B"
Case 51 To 60
GetGrade = "C+"
Case 41 To 50
GetGrade = "C"
Case 33 To 40
GetGrade = "D"
Case 0 To 32
GetGrade = "E"
Case Else
GetGrade = ""
End Select
End Function
'---------------------------
' Custom rounding function:
' If the fractional part is less than 0.5, return the integer part.
' If the fractional part is 0.5 or greater, return the integer part plus one.
Function CustomRound(val As Double) As Long
Dim intPart As Long, frac As Double
intPart = Fix(val)
frac = val - intPart
If frac >= 0.5 Then
CustomRound = intPart + 1
Else
CustomRound = intPart
End If
End Function
For class 6-8
Copy and run the code below to calculate T2 marks
(FA-1: 10 marks + FA-2: 10 marks + SA-2: 80 marks).
Option Explicit
Sub ProcessData()
Dim wsSource As Worksheet, wsSorted As Worksheet, wsOutput As Worksheet, wsRound As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim headerRow As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'---------------------------
' Step 1. Use the active sheet as the source data.
Set wsSource = ActiveSheet
'---------------------------
' Step 2. Ensure Sheet2 exists for sorted data.
On Error Resume Next
Set wsSorted = Worksheets("Sheet2")
If wsSorted Is Nothing Then
Set wsSorted = Worksheets.Add(After:=wsSource)
wsSorted.Name = "Sheet2"
Else
wsSorted.Cells.Clear
End If
'---------------------------
' Step 3. Ensure Sheet3 exists for final output (without grade columns).
Set wsOutput = Worksheets("Sheet3")
If wsOutput Is Nothing Then
Set wsOutput = Worksheets.Add(After:=wsSorted)
wsOutput.Name = "Sheet3"
Else
wsOutput.Cells.Clear
End If
On Error GoTo 0
'---------------------------
' Step 4. Delete empty Remark columns from wsSource.
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Set headerRow = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol))
For j = lastCol To 1 Step -1
If InStr(1, wsSource.Cells(1, j).Value, "Remark", vbTextCompare) > 0 Then
' Delete if only the header is nonblank.
If Application.WorksheetFunction.CountA(wsSource.Columns(j)) = 1 Then
wsSource.Columns(j).Delete
End If
End If
Next j
'---------------------------
' Step 5. Copy cleaned data to Sheet2 and sort by Student Name.
wsSource.UsedRange.Copy Destination:=wsSorted.Range("A1")
' Find the Student Name column.
lastCol = wsSorted.Cells(1, wsSorted.Columns.Count).End(xlToLeft).Column
Dim colStudentName As Long: colStudentName = 0
For j = 1 To lastCol
If InStr(1, wsSorted.Cells(1, j).Value, "Student Name", vbTextCompare) > 0 Then
colStudentName = j
Exit For
End If
Next j
If colStudentName > 0 Then
lastRow = wsSorted.Cells(wsSorted.Rows.Count, colStudentName).End(xlUp).Row
wsSorted.Range("A1").CurrentRegion.Sort Key1:=wsSorted.Cells(2, colStudentName), Order1:=xlAscending, Header:=xlYes
Else
MsgBox "Student Name column not found in Sheet2!", vbExclamation
GoTo CleanUp
End If
'---------------------------
' Step 6. Copy sorted data to Sheet3 for further processing.
wsSorted.UsedRange.Copy Destination:=wsOutput.Range("A1")
lastRow = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row
'---------------------------
' Step 7. Insert Average Columns for subject groups.
Dim english1Col As Long, english2Col As Long, colEnglishAvg As Long
Dim hiscivCol As Long, geographyCol As Long, colHisCivAvg As Long
Dim colPhysics As Long, colChemistry As Long, colBiology As Long, colChemBioPhyAvg As Long
'--- For English Average (from English 1 and English 2) ---
english1Col = FindColumn(wsOutput, "English 1")
english2Col = FindColumn(wsOutput, "English 2")
If english1Col > 0 And english2Col > 0 Then
wsOutput.Columns(english2Col + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, english2Col + 1).Value = "English Average"
colEnglishAvg = english2Col + 1
For i = 2 To lastRow
wsOutput.Cells(i, colEnglishAvg).Value = CustomRound((Val(wsOutput.Cells(i, english1Col).Value) + _
Val(wsOutput.Cells(i, english2Col).Value)) / 2)
Next i
Else
Dim colEnglishAlt As Long
colEnglishAlt = FindColumn(wsOutput, "English")
If colEnglishAlt > 0 Then
wsOutput.Columns(colEnglishAlt + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colEnglishAlt + 1).Value = "English Average"
colEnglishAvg = colEnglishAlt + 1
For i = 2 To lastRow
wsOutput.Cells(i, colEnglishAvg).Value = CustomRound(Val(wsOutput.Cells(i, colEnglishAlt).Value))
Next i
Else
MsgBox "No English columns found.", vbCritical
GoTo CleanUp
End If
End If
'--- For His/Civ Average (from His/Civ and Geography) ---
hiscivCol = FindColumn(wsOutput, "His/Civ")
geographyCol = FindColumn(wsOutput, "Geography")
If hiscivCol > 0 And geographyCol > 0 Then
wsOutput.Columns(geographyCol + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, geographyCol + 1).Value = "His/Civ Average"
colHisCivAvg = geographyCol + 1
For i = 2 To lastRow
wsOutput.Cells(i, colHisCivAvg).Value = CustomRound((Val(wsOutput.Cells(i, hiscivCol).Value) + _
Val(wsOutput.Cells(i, geographyCol).Value)) / 2)
Next i
Else
Dim colSocialScience As Long
colSocialScience = FindColumn(wsOutput, "Social Science")
If colSocialScience > 0 Then
wsOutput.Columns(colSocialScience + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colSocialScience + 1).Value = "His/Civ Average"
colHisCivAvg = colSocialScience + 1
For i = 2 To lastRow
wsOutput.Cells(i, colHisCivAvg).Value = CustomRound(Val(wsOutput.Cells(i, colSocialScience).Value))
Next i
Else
MsgBox "Neither History/Geography nor Social Science columns found.", vbCritical
GoTo CleanUp
End If
End If
'--- For Chem/Bio/Phy Average (from Physics, Chemistry and Biology) ---
colPhysics = FindColumn(wsOutput, "Physics")
colChemistry = FindColumn(wsOutput, "Chemistry")
colBiology = FindColumn(wsOutput, "Biology")
If colPhysics > 0 And colChemistry > 0 And colBiology > 0 Then
Dim maxGroupCol As Long
maxGroupCol = Application.WorksheetFunction.Max(colPhysics, colChemistry, colBiology)
wsOutput.Columns(maxGroupCol + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, maxGroupCol + 1).Value = "Chem/Bio/Phy Average"
colChemBioPhyAvg = maxGroupCol + 1
For i = 2 To lastRow
wsOutput.Cells(i, colChemBioPhyAvg).Value = CustomRound((Val(wsOutput.Cells(i, colPhysics).Value) + _
Val(wsOutput.Cells(i, colChemistry).Value) + _
Val(wsOutput.Cells(i, colBiology).Value)) / 3)
Next i
Else
Dim colEVS As Long
colEVS = FindColumn(wsOutput, "EVS")
If colEVS > 0 Then
wsOutput.Columns(colEVS + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colEVS + 1).Value = "Chem/Bio/Phy Average"
colChemBioPhyAvg = colEVS + 1
For i = 2 To lastRow
wsOutput.Cells(i, colChemBioPhyAvg).Value = CustomRound(Val(wsOutput.Cells(i, colEVS).Value))
Next i
Else
MsgBox "Neither Chemistry/Physics/Biology nor EVS column found.", vbCritical
GoTo CleanUp
End If
End If
'---------------------------
' Step 8. Append Overall Totals.
Dim colTotalMarks As Long, colPercentage As Long, colOverallGrade As Long
lastCol = wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Column
colTotalMarks = lastCol + 1
wsOutput.Cells(1, colTotalMarks).Value = "Total Marks"
colPercentage = colTotalMarks + 1
wsOutput.Cells(1, colPercentage).Value = "Total Percentage"
colOverallGrade = colPercentage + 1
wsOutput.Cells(1, colOverallGrade).Value = "Overall Grade"
Dim englishScore As Double, kannadaScore As Double, hindiScore As Double, mathsScore As Double
Dim hiscivScore As Double, chemBioPhyScore As Double, computerScore As Double
Dim gkScore As Double, moralScore As Double, drawingScore As Double
Dim totalMarks As Double, totalPercentage As Double
Dim subjectCount As Long, maxTotalMarks As Long
Dim avgSubjectCount As Long, remainingSubjectCount As Long
Dim colKannada As Long, colMaths As Long, colComputer As Long
colKannada = FindColumn(wsOutput, "Kannada")
colMaths = FindColumn(wsOutput, "Maths")
colComputer = FindColumn(wsOutput, "Computer")
' Essential subjects check:
If colKannada = 0 Or colMaths = 0 Or colComputer = 0 Or colEnglishAvg = 0 Then
MsgBox "One or more essential columns (English, Kannada, Maths, Computer) not found.", vbCritical
GoTo CleanUp
End If
' Optional subject columns (if available).
Dim colHindi As Long, colGK As Long, colMoral As Long, colDrawing As Long
colHindi = FindColumn(wsOutput, "Hindi")
colGK = FindColumn(wsOutput, "GK")
colMoral = FindColumn(wsOutput, "Moral")
colDrawing = FindColumn(wsOutput, "Drawing")
' Count subjects in two groups:
' Group A: Averaged subjects (each counts as one) — English Average, His/Civ Average, Chem/Bio/Phy Average.
avgSubjectCount = 3
' Group B: Remaining subjects (individual marks).
remainingSubjectCount = 0
remainingSubjectCount = remainingSubjectCount + 1 ' Kannada
If colHindi <> 0 Then remainingSubjectCount = remainingSubjectCount + 1
remainingSubjectCount = remainingSubjectCount + 1 ' Maths
remainingSubjectCount = remainingSubjectCount + 1 ' Computer
If colGK <> 0 Then remainingSubjectCount = remainingSubjectCount + 1
If colMoral <> 0 Then remainingSubjectCount = remainingSubjectCount + 1
If colDrawing <> 0 Then remainingSubjectCount = remainingSubjectCount + 1
subjectCount = avgSubjectCount + remainingSubjectCount
maxTotalMarks = subjectCount * 100
For i = 2 To lastRow
englishScore = Val(wsOutput.Cells(i, colEnglishAvg).Value)
kannadaScore = Val(wsOutput.Cells(i, colKannada).Value)
If colHindi <> 0 Then
hindiScore = Val(wsOutput.Cells(i, colHindi).Value)
Else
hindiScore = 0
End If
mathsScore = Val(wsOutput.Cells(i, colMaths).Value)
hiscivScore = Val(wsOutput.Cells(i, colHisCivAvg).Value)
chemBioPhyScore = Val(wsOutput.Cells(i, colChemBioPhyAvg).Value)
computerScore = Val(wsOutput.Cells(i, colComputer).Value)
If colGK <> 0 Then
gkScore = Val(wsOutput.Cells(i, colGK).Value)
Else
gkScore = 0
End If
If colMoral <> 0 Then
moralScore = Val(wsOutput.Cells(i, colMoral).Value)
Else
moralScore = 0
End If
If colDrawing <> 0 Then
drawingScore = Val(wsOutput.Cells(i, colDrawing).Value)
Else
drawingScore = 0
End If
totalMarks = englishScore + kannadaScore + hindiScore + mathsScore + hiscivScore + chemBioPhyScore + computerScore + gkScore + moralScore + drawingScore
wsOutput.Cells(i, colTotalMarks).Value = totalMarks
totalPercentage = (totalMarks / maxTotalMarks) * 100
wsOutput.Cells(i, colPercentage).Value = Round(totalPercentage, 2)
wsOutput.Cells(i, colOverallGrade).Value = GetGrade(CustomRound(totalPercentage))
Next i
'---------------------------
' Step 9. Create Sheet4: First apply rounding to calculated columns, then insert Grade columns.
On Error Resume Next
Set wsRound = Worksheets("Sheet4")
If wsRound Is Nothing Then
Set wsRound = Worksheets.Add(After:=wsOutput)
wsRound.Name = "Sheet4"
Else
wsRound.Cells.Clear
End If
On Error GoTo 0
' Copy all data from Sheet3 to Sheet4.
wsOutput.UsedRange.Copy Destination:=wsRound.Range("A1")
lastRow = wsRound.Cells(wsRound.Rows.Count, 1).End(xlUp).Row
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
' First, apply the custom rounding on calculated columns.
Dim headerVal As String
For j = 1 To lastCol
headerVal = wsRound.Cells(1, j).Value
' Process columns with "Average" or "Total" (exclude any column already containing "Grade").
If (InStr(1, headerVal, "Average", vbTextCompare) > 0 Or _
InStr(1, headerVal, "Total", vbTextCompare) > 0) And _
(InStr(1, headerVal, "Grade", vbTextCompare) = 0) Then
For i = 2 To lastRow
If IsNumeric(wsRound.Cells(i, j).Value) Then
wsRound.Cells(i, j).Value = CustomRound(wsRound.Cells(i, j).Value)
End If
Next i
End If
Next j
' --- NEW BLOCK: Recalculate Total Percentage and Overall Grade in Sheet4 based on Total Marks ---
Dim colTotalMarksS4 As Long, colPercS4 As Long, colGradeS4 As Long
For j = 1 To lastCol
Select Case wsRound.Cells(1, j).Value
Case "Total Marks": colTotalMarksS4 = j
Case "Total Percentage": colPercS4 = j
Case "Overall Grade": colGradeS4 = j
End Select
Next j
' Set maximum total marks to 1000 (10 subjects × 100 marks each).
Dim maxTotal As Double: maxTotal = 1000
If colTotalMarksS4 > 0 And colPercS4 > 0 And colGradeS4 > 0 Then
For i = 2 To lastRow
Dim totMarks As Double, perc As Double
totMarks = wsRound.Cells(i, colTotalMarksS4).Value
perc = (totMarks / maxTotal) * 100
' Use CustomRound for percentage rounding: if fractional part is <0.5 round down, >=0.5 round up.
wsRound.Cells(i, colPercS4).Value = CustomRound(perc)
wsRound.Cells(i, colGradeS4).Value = GetGrade(CustomRound(perc))
Next i
End If
' Now, insert Grade columns for each calculated subject column.
' Define the keywords to determine which columns get a grade column.
Dim keywords As Variant
keywords = Array("English", "Kannada", "Hindi", "His/Civ", "Geography", "Social Science", _
"Maths", "Physics", "Chemistry", "Biology", "Computer", "Average", _
"EVS", "GK", "Moral", "Drawing")
' Loop backward from the last column to avoid shifting issues.
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
For j = lastCol To 1 Step -1
headerVal = wsRound.Cells(1, j).Value
' Exclude identifier columns.
If InStr(1, headerVal, "Total", vbTextCompare) = 0 And _
InStr(1, headerVal, "Roll Number", vbTextCompare) = 0 And _
InStr(1, headerVal, "Student Name", vbTextCompare) = 0 And _
InStr(1, headerVal, "Class", vbTextCompare) = 0 And _
InStr(1, headerVal, "Section", vbTextCompare) = 0 And _
InStr(1, headerVal, "Grade", vbTextCompare) = 0 Then
Dim qualifies As Boolean: qualifies = False
Dim k As Integer
For k = LBound(keywords) To UBound(keywords)
If InStr(1, headerVal, keywords(k), vbTextCompare) > 0 Then
qualifies = True
Exit For
End If
Next k
If qualifies Then
wsRound.Columns(j + 1).Insert Shift:=xlToRight
wsRound.Cells(1, j + 1).Value = headerVal & " Grade"
For i = 2 To lastRow
Dim cellVal As Double
cellVal = Val(wsRound.Cells(i, j).Value)
wsRound.Cells(i, j + 1).Value = GetGrade(cellVal)
Next i
End If
End If
Next j
CleanUp:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Processing complete!", vbInformation
End Sub
'---------------------------
' Helper function: Finds the column number where the header cell contains headerText.
Function FindColumn(ws As Worksheet, headerText As String) As Long
Dim lastCol As Long, j As Long
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
If InStr(1, ws.Cells(1, j).Value, headerText, vbTextCompare) > 0 Then
FindColumn = j
Exit Function
End If
Next j
FindColumn = 0
End Function
'---------------------------
' Grade scale function using your provided grading scale.
Function GetGrade(marks As Double) As String
Select Case marks
Case 91 To 100
GetGrade = "A+"
Case 81 To 90
GetGrade = "A"
Case 71 To 80
GetGrade = "B+"
Case 61 To 70
GetGrade = "B"
Case 51 To 60
GetGrade = "C+"
Case 41 To 50
GetGrade = "C"
Case 33 To 40
GetGrade = "D"
Case 0 To 32
GetGrade = "E"
Case Else
GetGrade = ""
End Select
End Function
'---------------------------
' Custom rounding function:
' If the fractional part is less than 0.5, return the integer part.
' If the fractional part is 0.5 or greater, return the integer part plus one.
Function CustomRound(val As Double) As Long
Dim intPart As Long, frac As Double
intPart = Fix(val)
frac = val - intPart
If frac >= 0.5 Then
CustomRound = intPart + 1
Else
CustomRound = intPart
End If
End Function
For class 9-10
Copy and run the code below to calculate T2 marks
(FA-1: 10 marks + FA-2: 10 marks + SA-2: 80 marks).
Option Explicit
Sub ProcessData()
Dim wsSource As Worksheet, wsSorted As Worksheet, wsOutput As Worksheet, wsRound As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim headerRow As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'---------------------------
' Step 1. Use the active sheet as the source data.
Set wsSource = ActiveSheet
'---------------------------
' Step 2. Ensure Sheet2 exists for sorted data.
On Error Resume Next
Set wsSorted = Worksheets("Sheet2")
If wsSorted Is Nothing Then
Set wsSorted = Worksheets.Add(After:=wsSource)
wsSorted.Name = "Sheet2"
Else
wsSorted.Cells.Clear
End If
'---------------------------
' Step 3. Ensure Sheet3 exists for final output (without grade columns).
Set wsOutput = Worksheets("Sheet3")
If wsOutput Is Nothing Then
Set wsOutput = Worksheets.Add(After:=wsSorted)
wsOutput.Name = "Sheet3"
Else
wsOutput.Cells.Clear
End If
On Error GoTo 0
'---------------------------
' Step 4. Delete empty Remark columns from wsSource.
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Set headerRow = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol))
For j = lastCol To 1 Step -1
If InStr(1, wsSource.Cells(1, j).Value, "Remark", vbTextCompare) > 0 Then
' Delete if only the header is nonblank.
If Application.WorksheetFunction.CountA(wsSource.Columns(j)) = 1 Then
wsSource.Columns(j).Delete
End If
End If
Next j
'---------------------------
' Step 5. Copy cleaned data to Sheet2 and sort by Student Name.
wsSource.UsedRange.Copy Destination:=wsSorted.Range("A1")
' Find the Student Name column.
lastCol = wsSorted.Cells(1, wsSorted.Columns.Count).End(xlToLeft).Column
Dim colStudentName As Long: colStudentName = 0
For j = 1 To lastCol
If InStr(1, wsSorted.Cells(1, j).Value, "Student Name", vbTextCompare) > 0 Then
colStudentName = j
Exit For
End If
Next j
If colStudentName > 0 Then
lastRow = wsSorted.Cells(wsSorted.Rows.Count, colStudentName).End(xlUp).Row
wsSorted.Range("A1").CurrentRegion.Sort Key1:=wsSorted.Cells(2, colStudentName), Order1:=xlAscending, Header:=xlYes
Else
MsgBox "Student Name column not found in Sheet2!", vbExclamation
GoTo CleanUp
End If
'---------------------------
' Step 6. Copy sorted data to Sheet3 for further processing.
wsSorted.UsedRange.Copy Destination:=wsOutput.Range("A1")
lastRow = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row
'---------------------------
' Step 7. Insert Average Columns for subject groups.
Dim english1Col As Long, english2Col As Long, colEnglishAvg As Long
Dim hiscivCol As Long, geographyCol As Long, colHisCivAvg As Long
Dim colPhysics As Long, colChemistry As Long, colBiology As Long, colChemBioPhyAvg As Long
'--- For English Average (from English 1 and English 2) ---
english1Col = FindColumn(wsOutput, "English 1")
english2Col = FindColumn(wsOutput, "English 2")
If english1Col > 0 And english2Col > 0 Then
wsOutput.Columns(english2Col + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, english2Col + 1).Value = "English Average"
colEnglishAvg = english2Col + 1
For i = 2 To lastRow
wsOutput.Cells(i, colEnglishAvg).Value = CustomRound((Val(wsOutput.Cells(i, english1Col).Value) + _
Val(wsOutput.Cells(i, english2Col).Value)) / 2)
Next i
Else
Dim colEnglishAlt As Long
colEnglishAlt = FindColumn(wsOutput, "English")
If colEnglishAlt > 0 Then
wsOutput.Columns(colEnglishAlt + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colEnglishAlt + 1).Value = "English Average"
colEnglishAvg = colEnglishAlt + 1
For i = 2 To lastRow
wsOutput.Cells(i, colEnglishAvg).Value = CustomRound(Val(wsOutput.Cells(i, colEnglishAlt).Value))
Next i
Else
MsgBox "No English columns found.", vbCritical
GoTo CleanUp
End If
End If
'--- For His/Civ Average (from His/Civ and Geography) ---
hiscivCol = FindColumn(wsOutput, "His/Civ")
geographyCol = FindColumn(wsOutput, "Geography")
If hiscivCol > 0 And geographyCol > 0 Then
wsOutput.Columns(geographyCol + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, geographyCol + 1).Value = "His/Civ Average"
colHisCivAvg = geographyCol + 1
For i = 2 To lastRow
wsOutput.Cells(i, colHisCivAvg).Value = CustomRound((Val(wsOutput.Cells(i, hiscivCol).Value) + _
Val(wsOutput.Cells(i, geographyCol).Value)) / 2)
Next i
Else
Dim colSocialScience As Long
colSocialScience = FindColumn(wsOutput, "Social Science")
If colSocialScience > 0 Then
wsOutput.Columns(colSocialScience + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colSocialScience + 1).Value = "His/Civ Average"
colHisCivAvg = colSocialScience + 1
For i = 2 To lastRow
wsOutput.Cells(i, colHisCivAvg).Value = CustomRound(Val(wsOutput.Cells(i, colSocialScience).Value))
Next i
Else
MsgBox "Neither History/Geography nor Social Science columns found.", vbCritical
GoTo CleanUp
End If
End If
'--- For Chem/Bio/Phy Average (from Physics, Chemistry and Biology) ---
colPhysics = FindColumn(wsOutput, "Physics")
colChemistry = FindColumn(wsOutput, "Chemistry")
colBiology = FindColumn(wsOutput, "Biology")
If colPhysics > 0 And colChemistry > 0 And colBiology > 0 Then
Dim maxGroupCol As Long
maxGroupCol = Application.WorksheetFunction.Max(colPhysics, colChemistry, colBiology)
wsOutput.Columns(maxGroupCol + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, maxGroupCol + 1).Value = "Chem/Bio/Phy Average"
colChemBioPhyAvg = maxGroupCol + 1
For i = 2 To lastRow
wsOutput.Cells(i, colChemBioPhyAvg).Value = CustomRound((Val(wsOutput.Cells(i, colPhysics).Value) + _
Val(wsOutput.Cells(i, colChemistry).Value) + _
Val(wsOutput.Cells(i, colBiology).Value)) / 3)
Next i
Else
Dim colEVS As Long
colEVS = FindColumn(wsOutput, "EVS")
If colEVS > 0 Then
wsOutput.Columns(colEVS + 1).Insert Shift:=xlToRight
wsOutput.Cells(1, colEVS + 1).Value = "Chem/Bio/Phy Average"
colChemBioPhyAvg = colEVS + 1
For i = 2 To lastRow
wsOutput.Cells(i, colChemBioPhyAvg).Value = CustomRound(Val(wsOutput.Cells(i, colEVS).Value))
Next i
Else
MsgBox "Neither Chemistry/Physics/Biology nor EVS column found.", vbCritical
GoTo CleanUp
End If
End If
'---------------------------
' Step 8. Append Overall Totals.
Dim colTotalMarks As Long, colPercentage As Long, colOverallGrade As Long
lastCol = wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Column
colTotalMarks = lastCol + 1
wsOutput.Cells(1, colTotalMarks).Value = "Total Marks"
colPercentage = colTotalMarks + 1
wsOutput.Cells(1, colPercentage).Value = "Total Percentage"
colOverallGrade = colPercentage + 1
wsOutput.Cells(1, colOverallGrade).Value = "Overall Grade"
Dim englishScore As Double, kannadaScore As Double, mathsScore As Double
Dim hiscivScore As Double, chemBioPhyScore As Double, computerScore As Double
Dim totalMarks As Double, totalPercentage As Double
Dim subjectCount As Long, maxTotalMarks As Long
Dim avgSubjectCount As Long, remainingSubjectCount As Long
Dim colKannada As Long, colMaths As Long, colComputer As Long
colKannada = FindColumn(wsOutput, "Kannada")
colMaths = FindColumn(wsOutput, "Maths")
colComputer = FindColumn(wsOutput, "Computer")
' Essential subjects check:
If colKannada = 0 Or colMaths = 0 Or colComputer = 0 Or colEnglishAvg = 0 Then
MsgBox "One or more essential columns (English, Kannada, Maths, Computer) not found.", vbCritical
GoTo CleanUp
End If
' Count subjects in two groups:
' Group A: Averaged subjects (each counts as one) — English Average, His/Civ Average, Chem/Bio/Phy Average.
avgSubjectCount = 3
' Group B: Remaining subjects (individual marks) — Kannada, Maths, Computer.
remainingSubjectCount = 3
subjectCount = avgSubjectCount + remainingSubjectCount
maxTotalMarks = subjectCount * 100
For i = 2 To lastRow
englishScore = Val(wsOutput.Cells(i, colEnglishAvg).Value)
kannadaScore = Val(wsOutput.Cells(i, colKannada).Value)
mathsScore = Val(wsOutput.Cells(i, colMaths).Value)
hiscivScore = Val(wsOutput.Cells(i, colHisCivAvg).Value)
chemBioPhyScore = Val(wsOutput.Cells(i, colChemBioPhyAvg).Value)
computerScore = Val(wsOutput.Cells(i, colComputer).Value)
totalMarks = englishScore + kannadaScore + mathsScore + hiscivScore + chemBioPhyScore + computerScore
wsOutput.Cells(i, colTotalMarks).Value = totalMarks
totalPercentage = (totalMarks / maxTotalMarks) * 100
wsOutput.Cells(i, colPercentage).Value = Round(totalPercentage, 2)
wsOutput.Cells(i, colOverallGrade).Value = GetGrade(CustomRound(totalPercentage))
Next i
'---------------------------
' Step 9. Create Sheet4: First apply rounding to calculated columns, then insert Grade columns.
On Error Resume Next
Set wsRound = Worksheets("Sheet4")
If wsRound Is Nothing Then
Set wsRound = Worksheets.Add(After:=wsOutput)
wsRound.Name = "Sheet4"
Else
wsRound.Cells.Clear
End If
On Error GoTo 0
' Copy all data from Sheet3 to Sheet4.
wsOutput.UsedRange.Copy Destination:=wsRound.Range("A1")
lastRow = wsRound.Cells(wsRound.Rows.Count, 1).End(xlUp).Row
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
' First, apply the custom rounding on calculated columns.
Dim headerVal As String
For j = 1 To lastCol
headerVal = wsRound.Cells(1, j).Value
' Process columns with "Average" or "Total" (exclude any column already containing "Grade").
If (InStr(1, headerVal, "Average", vbTextCompare) > 0 Or _
InStr(1, headerVal, "Total", vbTextCompare) > 0) And _
(InStr(1, headerVal, "Grade", vbTextCompare) = 0) Then
For i = 2 To lastRow
If IsNumeric(wsRound.Cells(i, j).Value) Then
wsRound.Cells(i, j).Value = CustomRound(wsRound.Cells(i, j).Value)
End If
Next i
End If
Next j
' --- Recalculate Total Percentage and Overall Grade in Sheet4 based on Total Marks ---
Dim colTotalMarksS4 As Long, colPercS4 As Long, colGradeS4 As Long
For j = 1 To lastCol
Select Case wsRound.Cells(1, j).Value
Case "Total Marks": colTotalMarksS4 = j
Case "Total Percentage": colPercS4 = j
Case "Overall Grade": colGradeS4 = j
End Select
Next j
' Set maximum total marks to 600 (6 subjects × 100 marks each).
Dim maxTotal As Double: maxTotal = 600
If colTotalMarksS4 > 0 And colPercS4 > 0 And colGradeS4 > 0 Then
For i = 2 To lastRow
Dim totMarks As Double, perc As Double
totMarks = wsRound.Cells(i, colTotalMarksS4).Value
perc = (totMarks / maxTotal) * 100
wsRound.Cells(i, colPercS4).Value = CustomRound(perc)
wsRound.Cells(i, colGradeS4).Value = GetGrade(CustomRound(perc))
Next i
End If
' Now, insert Grade columns for each calculated subject column.
' Define the keywords to determine which columns get a grade column.
Dim keywords As Variant
keywords = Array("English", "Kannada", "His/Civ", "Geography", "Social Science", _
"Maths", "Physics", "Chemistry", "Biology", "Computer", "Average", "EVS")
' Loop backward from the last column to avoid shifting issues.
lastCol = wsRound.Cells(1, wsRound.Columns.Count).End(xlToLeft).Column
For j = lastCol To 1 Step -1
headerVal = wsRound.Cells(1, j).Value
' Exclude identifier columns.
If InStr(1, headerVal, "Total", vbTextCompare) = 0 And _
InStr(1, headerVal, "Roll Number", vbTextCompare) = 0 And _
InStr(1, headerVal, "Student Name", vbTextCompare) = 0 And _
InStr(1, headerVal, "Class", vbTextCompare) = 0 And _
InStr(1, headerVal, "Section", vbTextCompare) = 0 And _
InStr(1, headerVal, "Grade", vbTextCompare) = 0 Then
Dim qualifies As Boolean: qualifies = False
Dim k As Integer
For k = LBound(keywords) To UBound(keywords)
If InStr(1, headerVal, keywords(k), vbTextCompare) > 0 Then
qualifies = True
Exit For
End If
Next k
If qualifies Then
wsRound.Columns(j + 1).Insert Shift:=xlToRight
wsRound.Cells(1, j + 1).Value = headerVal & " Grade"
For i = 2 To lastRow
Dim cellVal As Double
cellVal = Val(wsRound.Cells(i, j).Value)
wsRound.Cells(i, j + 1).Value = GetGrade(cellVal)
Next i
End If
End If
Next j
CleanUp:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Processing complete!", vbInformation
End Sub
'---------------------------
' Helper function: Finds the column number where the header cell contains headerText.
Function FindColumn(ws As Worksheet, headerText As String) As Long
Dim lastCol As Long, j As Long
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
If InStr(1, ws.Cells(1, j).Value, headerText, vbTextCompare) > 0 Then
FindColumn = j
Exit Function
End If
Next j
FindColumn = 0
End Function
'---------------------------
' Grade scale function using your provided grading scale.
Function GetGrade(marks As Double) As String
Select Case marks
Case 91 To 100
GetGrade = "A+"
Case 81 To 90
GetGrade = "A"
Case 71 To 80
GetGrade = "B+"
Case 61 To 70
GetGrade = "B"
Case 51 To 60
GetGrade = "C+"
Case 41 To 50
GetGrade = "C"
Case 33 To 40
GetGrade = "D"
Case 0 To 32
GetGrade = "E"
Case Else
GetGrade = ""
End Select
End Function
'---------------------------
' Custom rounding function:
' If the fractional part is less than 0.5, return the integer part.
' If the fractional part is 0.5 or greater, return the integer part plus one.
Function CustomRound(val As Double) As Long
Dim intPart As Long, frac As Double
intPart = Fix(val)
frac = val - intPart
If frac >= 0.5 Then
CustomRound = intPart + 1
Else
CustomRound = intPart
End If
End Function
