Thema: Einfaches Quiz mit 2 vorgegebenen Antworten

ClassModule: frmQuiz

Private Sub cmdAnswer1_Click()
   Call ClickAnswer(cmdAnswer1)
End Sub

Private Sub cmdAnswer2_Click()
   Call ClickAnswer(cmdAnswer2)
End Sub

Private Sub ClickAnswer(cmd As Control)
   Dim rng As Range
   Dim iCol As Integer
   lblAnswer.Caption = cmd.Caption
   With ThisWorkbook.Worksheets("Fragen")
      Set rng = .Columns("B:C").Find(cmd.Caption, lookat:=xlWhole, LookIn:=xlValues)
      .Cells(spnQuiz.Value, 4).Value = rng.Column
   End With
   If spnQuiz.Value = 20 Then
      spnQuiz.Value = 1
   Else
      spnQuiz.Value = spnQuiz.Value + 1
   End If
End Sub

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdCompute_Click()
   Dim wks As Worksheet
   Dim iCount As Integer, iTrue As Integer, iAnswer As Integer
   Dim sTxt As String
   Set wks = ThisWorkbook.Worksheets("Fragen")
   iCount = WorksheetFunction.CountA(wks.Columns(1))
   iAnswer = WorksheetFunction.CountA(wks.Columns(4))
   iTrue = WorksheetFunction.CountIf(wks.Columns(4), 2)
   If iAnswer = 0 Then
      Beep
      MsgBox "Es wurde noch keine Frage beantwortet!"
      Exit Sub
   End If
   sTxt = "Anzahl Fragen beantwortet:" & vbLf
   sTxt = sTxt & iAnswer & " von "
   sTxt = sTxt & iCount & " = "
   sTxt = sTxt & Format(iAnswer / iCount, "0.00%") & vbLf & vbLf
   sTxt = sTxt & "Anteil richtige Antworten: " & vbLf
   sTxt = sTxt & iTrue & " von " & iAnswer & " = "
   sTxt = sTxt & Format(iTrue / iAnswer, "0.00%")
   MsgBox sTxt
End Sub

Private Sub cmdReset_Click()
   ThisWorkbook.Worksheets("Fragen").Columns(4).ClearContents
End Sub

Private Sub spnQuiz_Change()
   Dim wks As Worksheet
   Dim iCol As Integer, iSpan As Integer
   Set wks = ThisWorkbook.Worksheets("Fragen")
   iSpan = spnQuiz.Value
   lblNo.Caption = "Nr.: " & iSpan
   lblQuestion.Caption = wks.Cells(iSpan, 1).Value
   Randomize
   iCol = Int((2 * Rnd) + 1)
   If iCol = 1 Then
      cmdAnswer1.Caption = wks.Cells(iSpan, iCol + 1).Value
      cmdAnswer2.Caption = wks.Cells(iSpan, iCol + 2).Value
   Else
      cmdAnswer1.Caption = wks.Cells(iSpan, iCol + 1).Value
      cmdAnswer2.Caption = wks.Cells(iSpan, iCol).Value
   End If
   If Not IsEmpty(wks.Cells(iSpan, 4)) Then
      lblAnswer.Caption = wks.Cells(iSpan, wks.Cells(iSpan, 4).Value)
   Else
      lblAnswer.Caption = ""
   End If
End Sub

Private Sub UserForm_Initialize()
   Dim wks As Worksheet
   Set wks = ThisWorkbook.Worksheets("Fragen")
   With spnQuiz
      .Min = 1
      .Max = wks.Range("A1").CurrentRegion.Rows.Count
      .Value = 1
      wks.Columns(4).ClearContents
   End With
End Sub
StandardModule: basMain

Sub CallForm()
   frmQuiz.Show
End Sub

Sub ShowQuestions()
   Dim wks As Worksheet
   Dim sPW As String
   Set wks = ThisWorkbook.Worksheets("Fragen")
   If wks.Visible = xlSheetVisible Then
      wks.Visible = xlSheetVeryHidden
      Exit Sub
   End If
   sPW = InputBox("Passwort:", , "Admin")
   If sPW = "" Then Exit Sub
   If sPW <> "Admin" Then
      Beep
      MsgBox "Sorry, keine Zugangsberechtigung!"
   Else
      wks.Visible = xlSheetVisible
   End If
End Sub

Beiträge aus dem Excel-Forum zu den Themen Dialog und SpinButton