Excel VBA Kenyan School Exam Report Form

Thursday, 04 August, 2022

Private Sub CommandButton1_Click()
Dim shData As Worksheet
Dim shSubpos As Worksheet
Dim shSubGrade As Worksheet
Dim gradeSys As Worksheet
Dim subp As Worksheet

Dim lrow As Integer
Dim i, j As Integer
Dim maxSci, secsci, thirdsci, BestHumantech, compulsorySum, total As Double
Dim bestdub7 As Double
Dim arrV As Variant

Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Set subp = ThisWorkbook.Sheets("subpoints")
Set gradeSys = ThisWorkbook.Sheets("gradingSystem")
Set shData = ThisWorkbook.Sheets("DATA")
Set shSubpos = ThisWorkbook.Sheets("SUBJECTPOSITION")
Set shSubGrade = ThisWorkbook.Sheets("SUBJECT GRADE")

On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lrow = wf.CountA(shData.Range("A:A")) + 1
For j = 3 To 14
For i = 3 To lrow
shSubGrade.Range("A" & i).Value = shData.Range("A" & i)
shSubpos.Range("A" & i).Value = shData.Range("A" & i)
subp.Range("A" & i).Value = shData.Range("A" & i)

subp.Range("B" & i).Value = shData.Range("B" & i)

Set wf = Application.WorksheetFunction

If IsEmpty(shData.Range("C" & i)) Then
shSubGrade.Range("C" & i).Value = ""
Else
shSubGrade.Range("C" & i).Value = wf.VLookup(shData.Range("C" & i), gradeSys.Range("eng"), 2)
End If
If IsEmpty(shData.Range("D" & i)) Then
shSubGrade.Range("D" & i).Value = ""
Else
shSubGrade.Range("D" & i).Value = wf.VLookup(shData.Range("D" & i), gradeSys.Range("maths"), 2)
End If

If IsEmpty(shData.Range("E" & i)) Then
shSubGrade.Range("E" & i).Value = ""
Else
shSubGrade.Range("E" & i).Value = wf.VLookup(shData.Range("E" & i), gradeSys.Range("kis"), 2)
End If

If IsEmpty(shData.Range("F" & i)) Then
shSubGrade.Range("F" & i).Value = ""
Else
shSubGrade.Range("F" & i).Value = wf.VLookup(shData.Range("F" & i), gradeSys.Range("bio"), 2)
End If

If IsEmpty(shData.Range("G" & i)) Then
shSubGrade.Range("G" & i).Value = ""
Else
shSubGrade.Range("G" & i).Value = wf.VLookup(shData.Range("G" & i), gradeSys.Range("chem"), 2)
End If

If IsEmpty(shData.Range("H" & i)) Then
shSubGrade.Range("H" & i).Value = ""
Else
shSubGrade.Range("H" & i).Value = wf.VLookup(shData.Range("H" & i), gradeSys.Range("phy"), 2)
End If

If IsEmpty(shData.Range("I" & i)) Then
shSubGrade.Range("I" & i).Value = ""
Else
shSubGrade.Range("I" & i).Value = wf.VLookup(shData.Range("I" & i), gradeSys.Range("kis"), 2)
End If

If IsEmpty(shData.Range("J" & i)) Then
shSubGrade.Range("J" & i).Value = ""
Else
shSubGrade.Range("J" & i).Value = wf.VLookup(shData.Range("J" & i), gradeSys.Range("geog"), 2)
End If

If IsEmpty(shData.Range("K" & i)) Then
shSubGrade.Range("K" & i).Value = ""
Else
shSubGrade.Range("K" & i).Value = wf.VLookup(shData.Range("K" & i), gradeSys.Range("hist"), 2)
End If

If IsEmpty(shData.Range("L" & i)) Then
shSubGrade.Range("L" & i).Value = ""
Else
shSubGrade.Range("L" & i).Value = wf.VLookup(shData.Range("L" & i), gradeSys.Range("comp"), 2)
End If

If IsEmpty(shData.Range("M" & i)) Then
shSubGrade.Range("M" & i).Value = ""
Else
shSubGrade.Range("M" & i).Value = wf.VLookup(shData.Range("M" & i), gradeSys.Range("agric"), 2)
End If

If IsEmpty(shData.Range("N" & i)) Then
shSubGrade.Range("N" & i).Value = ""
Else
shSubGrade.Range("N" & i).Value = wf.VLookup(shData.Range("N" & i), gradeSys.Range("bst"), 2)
End If

If IsEmpty(shSubGrade.Cells(i, j).Value) Then
subp.Cells(i, j).Value = ""
ElseIf shSubGrade.Cells(i, j).Value = "A" Then
subp.Cells(i, j).Value = 12
ElseIf shSubGrade.Cells(i, j).Value = "A-" Then
subp.Cells(i, j).Value = 11
ElseIf shSubGrade.Cells(i, j).Value = "B+" Then
subp.Cells(i, j).Value = 10
ElseIf shSubGrade.Cells(i, j).Value = "B" Then
subp.Cells(i, j).Value = 9
ElseIf shSubGrade.Cells(i, j).Value = "B-" Then
subp.Cells(i, j).Value = 8
ElseIf shSubGrade.Cells(i, j).Value = "C+" Then
subp.Cells(i, j).Value = 7
ElseIf shSubGrade.Cells(i, j).Value = "C" Then
subp.Cells(i, j).Value = 6
ElseIf shSubGrade.Cells(i, j).Value = "C-" Then
subp.Cells(i, j).Value = 5
ElseIf shSubGrade.Cells(i, j).Value = "D+" Then
subp.Cells(i, j).Value = 4
ElseIf shSubGrade.Cells(i, j).Value = "D" Then
subp.Cells(i, j).Value = 3
ElseIf shSubGrade.Cells(i, j).Value = "D-" Then
subp.Cells(i, j).Value = 2
ElseIf shSubGrade.Cells(i, j).Value = "E" Then
subp.Cells(i, j).Value = 1

End If

Next i
Next j
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
subjectRank
grade
Call copyStreams
End Sub
Sub subjectRank()
Dim shData As Worksheet
Dim shSubpos As Worksheet
Dim erow As Long
Dim t As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
On Error Resume Next
Set shData = ThisWorkbook.Sheets("DATA")
Set shSubpos = ThisWorkbook.Sheets("SUBJECTPOSITION")
erow = wf.CountA(shData.Range("A:A"))
For t = 3 To erow
shSubpos.Range("C" & t) = wf.Rank(shData.Range("C" & t), shData.Range("C" & 3 & ":C" & erow), 0)
shSubpos.Range("D" & t) = wf.Rank(shData.Range("D" & t), shData.Range("D" & 3 & ":D" & erow), 0)
shSubpos.Range("E" & t) = wf.Rank(shData.Range("E" & t), shData.Range("E" & 3 & ":E" & erow), 0)
shSubpos.Range("F" & t) = wf.Rank(shData.Range("F" & t), shData.Range("F" & 3 & ":F" & erow), 0)
shSubpos.Range("G" & t) = wf.Rank(shData.Range("G" & t), shData.Range("G" & 3 & ":G" & erow), 0)
shSubpos.Range("H" & t) = wf.Rank(shData.Range("H" & t), shData.Range("H" & 3 & ":H" & erow), 0)
shSubpos.Range("I" & t) = wf.Rank(shData.Range("I" & t), shData.Range("I" & 3 & ":I" & erow), 0)
shSubpos.Range("J" & t) = wf.Rank(shData.Range("J" & t), shData.Range("J" & 3 & ":J" & erow), 0)
shSubpos.Range("K" & t) = wf.Rank(shData.Range("K" & t), shData.Range("K" & 3 & ":K" & erow), 0)
shSubpos.Range("L" & t) = wf.Rank(shData.Range("L" & t), shData.Range("L" & 3 & ":L" & erow), 0)
shSubpos.Range("M" & t) = wf.Rank(shData.Range("M" & t), shData.Range("M" & 3 & ":M" & erow), 0)
shSubpos.Range("N" & t) = wf.Rank(shData.Range("N" & t), shData.Range("N" & 3 & ":N" & erow), 0)
Next t
End Sub
Sub grade()
Dim shData As Worksheet
Dim shW As Worksheet
Dim y As Integer
Dim subp As Worksheet
Dim gradeSys As Worksheet
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Dim lrow As Integer
Dim i As Integer
Set subp = ThisWorkbook.Sheets("subpoints")
Set gradeSys = ThisWorkbook.Sheets("gradingSystem")
Set shData = ThisWorkbook.Sheets("DATA")
lrow = Application.WorksheetFunction.CountA(shData.Range("A:A"))
For i = 3 To lrow

maxScip = wf.Max(subp.Range("F" & i & ":H" & i))
maxScim = wf.Max(shData.Range("F" & i & ":H" & i))
secscip = wf.Large(subp.Range("F" & i & ":H" & i), 2)
secscim = wf.Large(shData.Range("F" & i & ":H" & i), 2)
thirdscip = wf.Min(subp.Range("F" & i & ":H" & i))
thirdscim = wf.Min(shData.Range("F" & i & ":H" & i))
compulsorySump = wf.Sum(subp.Range("C" & i & ":E" & i))
compulsorySumm = wf.Sum(shData.Range("C" & i & ":E" & i))

BestHumanityp = wf.Max(subp.Range("I" & i & ":K" & i))
BestHumanitym = wf.Max(shData.Range("I" & i & ":K" & i))
secBestHumanm = wf.Large(shData.Range("I" & i & ":K" & i), 2)
secBestHumanp = wf.Large(subp.Range("I" & i & ":K" & i), 2)
bestTechp = wf.Max(subp.Range("L" & i & ":N" & i), 2)
bestTechm = wf.Max(shData.Range("L" & i & ":N" & i), 2)

If wf.Max(thirdscip, secBestHumanp, bestTechp) = thirdscip Then
    bestsub7m = thirdscim
ElseIf wf.Max(thirdscip, secBestHumanp, bestTechp) = secBestHumanp Then
    bestsub7m = secBestHumanm
ElseIf wf.Max(thirdscip, secBestHumanp, bestTechp) = bestTechp Then
    bestsub7m = bestTechm
End If

totalp = compulsorySump + maxScip + secscip + bestsub7p + BestHumanityp
totalm = compulsorySumm + maxScim + secscim + bestsub7m + BestHumanitym
subp.Range("O" & i) = totalp
shData.Range("O" & i) = totalp
subp.Range("P" & i) = totalm
shData.Range("P" & i) = totalm

subp.Range("R" & i) = wf.Rank(subp.Range("O" & i), _
subp.Range("O" & 3 & ":O" & lrow), 0)

shData.Range("R" & i) = wf.Rank(subp.Range("O" & i), _
subp.Range("O" & 3 & ":O" & lrow), 0)

subp.Range("S" & i) = wf.CountIfs(subp.Range("B" & 3 & ":B" & lrow), _
subp.Range("B" & i), subp.Range("O" & 3 & ":O" & lrow), _
">" & subp.Range("O" & i)) + 1

shData.Range("S" & i) = wf.CountIfs(subp.Range("B" & 3 & ":B" & lrow), _
subp.Range("B" & i), subp.Range("O" & 3 & ":O" & lrow), _
">" & subp.Range("O" & i)) + 1

subp.Range("Q" & i).Value = _
wf.VLookup(subp.Range("O" & i), gradeSys.Range("points"), 2)
shData.Range("Q" & i).Value = wf.VLookup(subp.Range("O" & i), gradeSys.Range("points"), 2)

Next i
End Sub
Sub copyStreams()
Dim shData As Worksheet
Dim b As Long
Dim SHE As Worksheet
Dim shW As Worksheet
Dim l As Long
Dim shN As Worksheet

Dim c, R As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction

Set shData = ThisWorkbook.Sheets("DATA")
Set SHE = ThisWorkbook.Sheets("STREAST")
Set shW = ThisWorkbook.Sheets("WEST")
Set shN = ThisWorkbook.Sheets("NORTH")
l = wf.CountA(shData.Range("A:A"))

shData.Cells(1, 1).AutoFilter Field:=2, Criteria1:="EAST"
shData.Cells(1, 1).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
SHE.Select

SHE.Cells(1, 1).Select

SHE.Paste
shData.Activate

shData.Rows(1).Select
Selection.AutoFilter
shData.Cells(1, 1).Select

shData.Cells(1, 1).AutoFilter Field:=2, Criteria1:="WEST"
shData.Cells(1, 1).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
shW.Select

shW.Cells(1, 1).Select

shW.Paste
shData.Activate

shData.Rows(1).Select
Selection.AutoFilter
shData.Cells(1, 1).Select

shData.Cells(1, 1).AutoFilter Field:=2, Criteria1:="NORTH"
shData.Cells(1, 1).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
shN.Select

shN.Cells(1, 1).Select

shN.Paste
shData.Activate

shData.Rows(1).Select
Selection.AutoFilter
shData.Cells(1, 1).Select

End Sub

Add comment