Sub Corregir(): On Error Resume Next
Set Preguntas = Sheets(ActiveSheet.Range("B1").Value)Set Examen = Sheets(ActiveSheet.Range("B2").Value)
Application.ScreenUpdating = False
Examen.Unprotect
Examen.Select
For x = 2 To Preguntas.Range("A" & Rows.Count).End(xlUp).Row r = Split(Preguntas.Range("C" & x), ";") For y = 4 To Preguntas.Cells(x, 3).End(xlToRight).Column
i = i + 1
Examen.OLEObjects(i).Object.BackColor = vbWhite
For Z = 0 To UBound(r)
If Examen.OLEObjects(i).Object.Value = True Then
errores = 0
If CStr(r(Z)) = CStr(y - 3) Then
Examen.OLEObjects(i).Object.BackColor = vbGreen
Aciertos = Aciertos + 1
Exit For
Else
Examen.OLEObjects(i).Object.BackColor = vbRed
errores = errores + 0.33
End If
End If
Next
TotalErrores = TotalErrores + errores
errores = 0
Next
Next
MsgBox "Preguntas acertadas = " & Aciertos & ", Calificacion = " & Format(Aciertos, "00.00") & Chr(10) & "Preguntas falladas = " & TotalErrores / 0.33 & ", Calificacion =" & Format(-TotalErrores, "00.00") & Chr(10) & Chr(10) & " Calificacion Total= " & Aciertos - TotalErrores
Examen.Protect
Examen.Select
End Sub
Crear cuenta