VBA Code to Circle Student Result

[drof_06]

Hi,

I'm attempting to write a macro that will circle a student result and then print their report. The report displays each possible result from A to E but only has the actual student result circled.

I've based this around three worksheets; on the first I have circled the letters A to E in five cells for copying; on the second I will have the student report that ends up being printed and shows the student grade circled; the third is just a list of student names and their result.

My attempt is inefficient and I'm not sure how to make it go through each student name. This is the macro so far:

Sub Macro1()
'
' Macro1 Macro
'
Sheet2.Ovals.Delete


Sheet2.Range("A1").Value = "A"
Sheet2.Range("B1").Value = "B"
Sheet2.Range("C1").Value = "C"
Sheet2.Range("D1").Value = "D"
Sheet2.Range("E1").Value = "E"


If Sheet3.Range("B2") = "A" Then
Sheets("Sheet1").Select
Sheet1.Range("F1").Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Range("A1").Select
ActiveSheet.Paste
End If


If Sheet3.Range("B2") = "B" Then
Sheets("Sheet1").Select
Sheet1.Range("G1").Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Range("B1").Select
ActiveSheet.Paste
End If


If Sheet3.Range("B2") = "C" Then
Sheets("Sheet1").Select
Sheet1.Range("H1").Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Range("C1").Select
ActiveSheet.Paste
End If


If Sheet3.Range("B2") = "D" Then
Sheets("Sheet1").Select
Sheet1.Range("I1").Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Range("D1").Select
ActiveSheet.Paste
End If


If Sheet3.Range("B2") = "E" Then
Sheets("Sheet1").Select
Sheet1.Range("J1").Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Range("E1").Select
ActiveSheet.Paste
End If




End Sub




It would be great if someone could give me some advice on this. Thank you.

 

[tlowry]

Ok, here’s my suggestion. It is a complete rewrite (sorry).

Instructions:

1. Start with a new Excel
2. Go to development mode (Alt F11)
3. Create a new module (Insert | Module)
4. Copy this code into module
5. Run macro CreateEnvironment once
6. Save File As
7. Run macro main to print (preview) reports
8. To print preview (not print) reports change the code PrintOut to PrintPreview.
9. Let me know about the bugs

Const ReportSheet = "Report"
Const StudentNames = "Students"

Sub CreateEnvironment() ' makes a test environment
    With ThisWorkbook.Sheets.Add    ' new report worksheet
        .Name = ReportSheet
        .Rows(1).RowHeight = 20
    End With
    With ThisWorkbook.Sheets.Add    ' data sheet & test data
        .Name = StudentNames
        .Range("A1:B1") = Array("Name", "Grade")
        .Range("A2:B2") = Array("Norma", "A")
        .Range("A3:B3") = Array("Fred", "No Show")
        .Range("A4:B4") = Array("Perry", "Inc.")
        .Range("A5:B5") = Array("Jane", "")
    End With
End Sub


'==========================================
'   Cycle through names and modifies report
'
Sub main()
    Application.ScreenUpdating = False
    Dim i As Long
    With Sheets(StudentNames)
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            DoOval i
            Sheets(ReportSheet).[B][COLOR=#0000cd]PrintOut[/COLOR][/B]
        Next i
    End With
    ClearReport 'Clears report worksheet
    Application.ScreenUpdating = True
End Sub
Sub DoOval(irow)
    Dim grades
    grades = Array("A", "B", "C", "D", "D-", "E", "Inc.") ' array of possible grades
    Dim g, ag
    On Local Error Resume Next
    Sheets(ReportSheet).Activate
    ClearReport
    For g = 0 To UBound(grades)               ' Fill in possible grades
        Cells(1, g + 1) = grades(g)
        Cells(1, g + 1).HorizontalAlignment = xlCenter
        Cells(1, g + 1).VerticalAlignment = xlCenter
        Cells(2, 1) = Sheets(StudentNames).Cells(irow, 1)
        If UCase(grades(g)) = UCase(Sheets(StudentNames).Cells(irow, 2)) Then ag = g + 1
    Next g
    If IsEmpty(ag) Then ' grade is invalid
        Application.Intersect(Rows(1), Cells(1, 1).CurrentRegion).ClearContents
        Cells(1, 1) = "N/A"
        ag = 1
    End If
    With Cells(1, ag)
        ActiveSheet.Shapes.AddShape(msoShapeOval, .Left, .Top, .Width, .Height).Select
    End With
    With Selection
        .Name = "GradeOval"
        .ShapeRange.Fill.Visible = msoFalse
        .ShapeRange.Line.ForeColor.SchemeColor = 12
        .ShapeRange.Line.Weight = 2
    End With
    Cells(2, 1).Activate
End Sub
Sub ClearReport()
    On Local Error Resume Next
    ActiveSheet.Shapes("GradeOval").Cut     ' get rid of previous oval
    ActiveSheet.Cells.ClearContents         ' get rid of report text
End Sub

 

[drof_06]

Thank you so much for taking the time to look at this.

Your code works perfectly and is just what I needed.

Thank you