Creating a small project in VBA Excel

Creating a small project in VBA Excel

Add Comment , Edit

Scenario :-

You have a dataset comprising of student names and their marks in various subjects. You have to calculate total marks obtained, percentage and the grades for all the students.Following table shows the maximum marks in each subjects and distribution of grades.
Subjects Marks
English 100
Hindi 100
Marathi 100
Maths 100
Science 100
Grades Percentage %
Excellent >=90
1 Class >=75
2 Class >=60
3 Class >=45
Pass >=35
Fail <35

Next task :-

You have to distribute the children based on their grades. Develop the code to create the following table along with the proper values.Later you have to put validation on those marks that are less than 35.
Grades No. of students
Excellent x
1 Class x
2 Class x
3 Class x
Pass x
Fail x

Optimization :-
Suppose you have entered the data and run the script it will calculate the total marks, percentage and grades of all the students. Now if you add more data in the sheet and again run the script then the above data which was calculated earlier will be calculated again which is not a good method.
So now you have to modify the script to calculate those rows in which data is changed or if any new data is added.

Let's Begin :-
In excel -
  • Go to the developer option and click on visual basic.
  • In visual basic tab click on Insert -> module

Now you can start writing the code.

Let us first create the table head. Following code will enter the values in the appropriate cell and also add cell color and text style to it.

Sub Project_Cal_Grade()

'Creating table head for the students data and adding cell color and text style to it.

Range("A1").Value = "Student Name"
Range("B1").Value = "Marks_1"
Range("C1").Value = "Marks_2"
Range("D1").Value = "Marks_3"
Range("E1").Value = "Marks_4"
Range("F1").Value = "Marks_5"
Range("G1").Value = "Total"
Range("H1").Value = "Percentage"
Range("I1").Value = "Grade"
Range("A1:I1, L1:M1, L2:L7").Font.Bold = True
Range("A1:I1, L1:M1").Font.ColorIndex = 1
Range("A1:I1, L1:M1").Interior.ColorIndex = 8

'Creating table for grade distribution

Range("L1").Value = "Grades"
Range("M1").Value = "No of Students"
Range("L2").Value = "Excellent"
Range("L2").Interior.ColorIndex = 4
Range("L3").Value = "1 Class"
Range("L3").Interior.ColorIndex = 36
Range("L4").Value = "2 Class"
Range("L4").Interior.ColorIndex = 44
Range("L5").Value = "3 Class"
Range("L5").Interior.ColorIndex = 22
Range("L6").Value = "Pass"
Range("L6").Interior.ColorIndex = 46
Range("L7").Value = "Fail"
Range("L7").Interior.ColorIndex = 3
Range("A1:Z10000").Columns.AutoFit
Range("A1:Z10000").HorizontalAlignment = xlCenter
Range("A1:Z10000").VerticalAlignment = xlCenter

End Sub

So we have reached till here -


Now let us write the logic for calculating the total marks, percentage and grades.

'Define the variables as long type

Dim i As Long, j As Long

'Define the lastRow type

Dim lastRow As Long

'Finding the lastrow in the sheet which contains data

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

'Define the lastColumn type

Dim lastColumn As Long
lastColumn = 9

'Writing the logic to calculate the total marks, percentage and grades

For j = 2 To lastRow
        Cells(j, lastColumn - 2).Value = 0
        For i = 2 To (lastColumn - 3)
            If (Cells(j, i).Value < 35) Then
                 Cells(j, i).Interior.ColorIndex = 38
            End If
            Cells(j, lastColumn - 2) = Cells(j, lastColumn - 2) + Application.WorksheetFunction.Sum(Cells(j, i))
        Next i
        Cells(j, 1).Interior.ColorIndex = 6
        Cells(j, lastColumn - 1) = Cells(j, lastColumn - 2) / 5
        If Cells(j, lastColumn - 1) > 90 Then
            Cells(j, lastColumn) = "Excellent"
            Cells(j, lastColumn).Interior.ColorIndex = 4
        ElseIf Cells(j, lastColumn - 1) > 75 Then
            Cells(j, lastColumn) = "1 Class"
            Cells(j, lastColumn).Interior.ColorIndex = 36
        ElseIf Cells(j, lastColumn - 1) > 60 Then
            Cells(j, lastColumn) = "2 Class"
            Cells(j, lastColumn).Interior.ColorIndex = 44
        ElseIf Cells(j, lastColumn - 1) > 45 Then
            Cells(j, lastColumn) = "3 Class"
            Cells(j, lastColumn).Interior.ColorIndex = 22
        ElseIf Cells(j, lastColumn - 1) > 34 Then
            Cells(j, lastColumn) = "Pass"
            Cells(j, lastColumn).Interior.ColorIndex = 46
        Else
            Cells(j, lastColumn) = "Fail"
            Cells(j, lastColumn).Interior.ColorIndex = 3
        End If
Next j

Let's enter the data in the table -


Now run the script -


Note: -We are highlighting the 1 cell of each row once the calculation is performed in the row.The main reason for dong this is if we change the data, then 1 cell color will be changed automatically. Let's write the code for it.


In the left panel of Visual Basic go to the particular sheet you are working on. In our case it's sheet1. Open it and paste the following code.


'Define the Range you want to work on. If any data is changed in a particular row, then in that row 1 cell color will be changed to white color

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:F1000")) Is Nothing Then
        Target.EntireRow.Cells(1, 1).Interior.ColorIndex = 2
    End If
End Sub

After running the script -


After changing the data in D3 cell-


When we run our latest code it will calculate required data for all rows. Let's use the logic we develop to change the color of cell in which the value is changed. If we are entering data in new row the 1 cell will be by default white color. We will be writing a code to skip those rows in which 1 cell is of yellow color.

'Define a if condition where if the 1 cell color of a row is white then only proceed with the calculation else skip the row.

If (Cells(j, 1).Interior.ColorIndex = 2) Then
.
.
.
.
.
.
End If

Now let us decorate our table by adding borders

'Bordering student table.

Dim rngBottomRowStart       As Range
Dim rngBottomRowEnd         As Range
Dim rngDataUpperLeftCell    As Range
Set rngDataUpperLeftCell = Range("A1")
With rngDataUpperLeftCell
    Set rngBottomRowStart = Cells(.End(xlDown).Row, .Column)
    Set rngBottomRowEnd = Cells(rngBottomRowStart.Row, .End(xlToRight).Column)
End With
If (lastRow > 1) Then
    Range(rngDataUpperLeftCell, rngBottomRowEnd).Borders.LineStyle = xlContinuous
End If

'Bordering distribution table.

Range("L1:M7").Borders.LineStyle = xlContinuous

We have almost achieved our goal -


So let's go for the second last part. From the grades column in the student table, we will the counting total number of students for each grades. 

Range("M2").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "Excellent")
Range("M3").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "1 Class")
Range("M4").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "2 Class")
Range("M5").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "3 Class")
Range("M6").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "Pass")
Range("M7").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "Fail")

We have almost achieved our goal -


So let's go for the last part. We will be adding validations to highlight cells in which marks entered is less than 35.. 

.
.
.
If (Cells(j, i).Value < 35) Then
   Cells(j, i).Interior.ColorIndex = 38
End If
.
.
.

Finally, We have achieved our goal -


So our final code will be :- 

Sub Project_Cal_Grade()


Range("A1").Value = "Student Name"
Range("B1").Value = "Marks_1"
Range("C1").Value = "Marks_2"
Range("D1").Value = "Marks_3"
Range("E1").Value = "Marks_4"
Range("F1").Value = "Marks_5"
Range("G1").Value = "Total"
Range("H1").Value = "Percentage"
Range("I1").Value = "Grade"
Range("A1:I1, L1:M1, L2:L7").Font.Bold = True
Range("A1:I1, L1:M1").Font.ColorIndex = 1
Range("A1:I1, L1:M1").Interior.ColorIndex = 8

Range("L1").Value = "Grades"
Range("M1").Value = "No of Students"
Range("L2").Value = "Excellent"
Range("L2").Interior.ColorIndex = 4
Range("L3").Value = "1 Class"
Range("L3").Interior.ColorIndex = 36
Range("L4").Value = "2 Class"
Range("L4").Interior.ColorIndex = 44
Range("L5").Value = "3 Class"
Range("L5").Interior.ColorIndex = 22
Range("L6").Value = "Pass"
Range("L6").Interior.ColorIndex = 46
Range("L7").Value = "Fail"
Range("L7").Interior.ColorIndex = 3
Range("L1:M7").Borders.LineStyle = xlContinuous

Dim i As Long, j As Long

Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim lastColumn As Long
lastColumn = 9

For j = 2 To lastRow
    If (Cells(j, 1).Interior.ColorIndex = 2) Then
        Cells(j, lastColumn - 2).Value = 0
        For i = 2 To (lastColumn - 3)
            If (Cells(j, i).Value < 35) Then
                 Cells(j, i).Interior.ColorIndex = 38
            End If
            Cells(j, lastColumn - 2) = Cells(j, lastColumn - 2) + Application.WorksheetFunction.Sum(Cells(j, i))
        Next i
        Cells(j, 1).Interior.ColorIndex = 6
        Cells(j, lastColumn - 1) = Cells(j, lastColumn - 2) / 5
        If Cells(j, lastColumn - 1) > 90 Then
            Cells(j, lastColumn) = "Excellent"
            Cells(j, lastColumn).Interior.ColorIndex = 4
        ElseIf Cells(j, lastColumn - 1) > 75 Then
            Cells(j, lastColumn) = "1 Class"
            Cells(j, lastColumn).Interior.ColorIndex = 36
        ElseIf Cells(j, lastColumn - 1) > 60 Then
            Cells(j, lastColumn) = "2 Class"
            Cells(j, lastColumn).Interior.ColorIndex = 44
        ElseIf Cells(j, lastColumn - 1) > 45 Then
            Cells(j, lastColumn) = "3 Class"
            Cells(j, lastColumn).Interior.ColorIndex = 22
        ElseIf Cells(j, lastColumn - 1) > 34 Then
            Cells(j, lastColumn) = "Pass"
            Cells(j, lastColumn).Interior.ColorIndex = 46
        Else
            Cells(j, lastColumn) = "Fail"
            Cells(j, lastColumn).Interior.ColorIndex = 3
        End If
    End If
Next j

Dim rngBottomRowStart       As Range
Dim rngBottomRowEnd         As Range
Dim rngDataUpperLeftCell    As Range
Set rngDataUpperLeftCell = Range("A1")
With rngDataUpperLeftCell
    Set rngBottomRowStart = Cells(.End(xlDown).Row, .Column)
    Set rngBottomRowEnd = Cells(rngBottomRowStart.Row, .End(xlToRight).Column)
End With
If (lastRow > 1) Then
    Range(rngDataUpperLeftCell, rngBottomRowEnd).Borders.LineStyle = xlContinuous
End If
Range("M2").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "Excellent")
Range("M3").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "1 Class")
Range("M4").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "2 Class")
Range("M5").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "3 Class")
Range("M6").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "Pass")
Range("M7").Value = Application.WorksheetFunction.CountIf(Range(rngDataUpperLeftCell, rngBottomRowEnd), "Fail")

Range("A1:Z10000").Columns.AutoFit
Range("A1:Z10000").HorizontalAlignment = xlCenter
Range("A1:Z10000").VerticalAlignment = xlCenter

End Sub

SHARE

Shubu

Hi. I’I hope this post was helpful for you.

    Blogger Comment
    Facebook Comment

0 comments:

Post a Comment

Subscribe to: Post Comments ( Atom )