Ecco il mio problema, ho trovato in rete un file che serve per esercitarsi con i quiz (bello e funzionante), così strutturato:
Foglio1: A: nr progressivo; B: domande; C:risposta multipla1; D:risposta multipla 2; E:risposta multipla 3; F:risposta multipla 4; G:risposta esatta.
Foglio2 così strutturato:
A1:Domanda corrente; A2:PB00135
B1:Domande lette;B2:5
C1:Domande esatte;C2:2
D1:Scorrimento;D2:Sequenziale/causale
E1:Domande Totali;E2:5014
A4:Indici domande
A5, A6, A7 e cosi via: AA;AB;BA;BB;CA;CB;DA;DB;EA;EB;FA;FB;GA;GB;HA;HB;IA;IB;LA;LB;MA;MB;PA;PB;RA;RB;SA;SB;ZA;ZB.
B4:Parziali
B5, B6, B7 e cosi via: 130;132;130;130;134;130;130;131;234;233;237;238;129;130;130;130;130;130;128;130;129;130;250;250;
249;252;235;234;129;130.
Vorrei implementarlo con 5 risposte multiple e sinceramente non so cosa fare essendo un neofita in VBA.
Chiedo gentilmente se mi potete risolvere il problema.
Grazie anticipatamente.
Allego il codice usato:
- Codice: Seleziona tutto
Dim RigaDomanda As Integer
Dim IndiceDomanda As Domanda
Dim DomandeLette As Integer
Dim DomandeEsatte As Integer
Dim PercentualeEsatte As Integer
Dim DomandaDaVerificare As Integer
Dim DomandeTotali As Integer
Dim UltimaDomandaCasualeRisposta As Integer
Private Sub CmbIndice_Change()
Dim Lettere As String * 2
Dim Numeri As String
Dim Cont1 As Integer
Dim Cont2 As Integer
Lettere = CmbIndice.Text
Numeri = "00001"
For Cont1 = 0 To UBound(IndiceDomanda.Indice)
If Lettere = IndiceDomanda.Indice(Cont1) Then
CmbNumero.Clear
For Cont2 = 1 To IndiceDomanda.Numero(Cont1)
CmbNumero.AddItem Format$(CStr(Cont2), "00000")
Next Cont2
CmbIndice.ListIndex = Cont1
CmbNumero.ListIndex = CInt(Numeri) - 1
End If
Next Cont1
Call AzzeraOpzioni
CmdVerificaRisposta.SetFocus
End Sub
Private Sub CmbNumero_Change()
If (CmbNumero.ListCount > 0) Then
RigaDomanda = RigaAssoluta(CmbIndice.Text & CmbNumero.Text)
Call LeggiDomanda(RigaDomanda)
End If
Call AzzeraOpzioni
CmdVerificaRisposta.SetFocus
End Sub
Private Sub CmdAzzeramento_Click()
Dim Risposta As VbMsgBoxResult
Risposta = MsgBox("Azzerare il conteggio ?", vbInformation + vbYesNo, "Attenzione")
If Risposta = vbYes Then
DomandeLette = 0
DomandeEsatte = 0
PercentualeEsatte = 0
DomandaDaVerificare = 0
Call NascondiFaccine
LblLette.Caption = CStr(DomandeLette)
LblEsatte.Caption = CStr(DomandeEsatte)
LblPercEsatte.Caption = CStr(PercentualeEsatte) & " %"
Me.MousePointer = 13
Foglio1.Range("H1:H1").EntireColumn.Delete
Me.MousePointer = 0
End If
Call AzzeraOpzioni
CmdVerificaRisposta.SetFocus
End Sub
Private Sub CmdIndietro_Click()
Dim Numero As Integer
Dim Cont As Integer
If OptSequenziale.Value = True Then
If RigaDomanda > 1 Then
RigaDomanda = RigaDomanda - 1
Call LeggiDomanda(RigaDomanda)
Call AzzeraOpzioni
End If
ElseIf OptCasuale.Value = True Then
If UltimaDomandaCasualeRisposta > 0 Then
RigaDomanda = UltimaDomandaCasualeRisposta
Call LeggiDomanda(RigaDomanda)
Call AzzeraOpzioni
End If
End If
Call AggiornaCombo
DomandaDaVerificare = 0
CmdVerificaRisposta.SetFocus
End Sub
Private Sub CmdAvanti_Click()
Dim NumeroCasuale As Integer
Dim StrTemp As String * 1
If OptSequenziale.Value = True Then
If RigaDomanda < DomandeTotali Then
RigaDomanda = RigaDomanda + 1
Call LeggiDomanda(RigaDomanda)
Call AzzeraOpzioni
End If
ElseIf OptCasuale.Value = True Then
Me.MousePointer = 13
Do
Randomize Timer
NumeroCasuale = Int((DomandeTotali * Rnd) + 1)
StrTemp = Foglio1.Cells(NumeroCasuale, 8)
Loop While (LCase(StrTemp) = "x")
RigaDomanda = NumeroCasuale
Call LeggiDomanda(RigaDomanda)
Call AzzeraOpzioni
Me.MousePointer = 0
End If
Call AggiornaCombo
DomandaDaVerificare = 0
CmdVerificaRisposta.SetFocus
End Sub
Private Sub CmdVerificaRisposta_Click()
Dim RispostaEsatta As String
Dim Cont As Integer
If ((OptRisposta1.Value = True) Or _
(OptRisposta2.Value = True) Or _
(OptRisposta3.Value = True) Or _
(OptRisposta4.Value = True)) Then
RispostaEsatta = Foglio1.Cells(RigaDomanda, 7)
RispostaEsatta = UCase(RispostaEsatta)
Select Case RispostaEsatta
Case Is = "A"
OptRisposta1.BackColor = vbGreen
If OptRisposta1.Value <> True Then
If OptRisposta2.Value = True Then
OptRisposta2.BackColor = vbRed
ElseIf OptRisposta3.Value = True Then
OptRisposta3.BackColor = vbRed
ElseIf OptRisposta4.Value = True Then
OptRisposta4.BackColor = vbRed
End If
Else
DomandeEsatte = DomandeEsatte + 1
End If
Case Is = "B"
OptRisposta2.BackColor = vbGreen
If OptRisposta2.Value <> True Then
If OptRisposta1.Value = True Then
OptRisposta1.BackColor = vbRed
ElseIf OptRisposta3.Value = True Then
OptRisposta3.BackColor = vbRed
ElseIf OptRisposta4.Value = True Then
OptRisposta4.BackColor = vbRed
End If
Else
DomandeEsatte = DomandeEsatte + 1
End If
Case Is = "C"
OptRisposta3.BackColor = vbGreen
If OptRisposta3.Value <> True Then
If OptRisposta1.Value = True Then
OptRisposta1.BackColor = vbRed
ElseIf OptRisposta2.Value = True Then
OptRisposta2.BackColor = vbRed
ElseIf OptRisposta4.Value = True Then
OptRisposta4.BackColor = vbRed
End If
Else
DomandeEsatte = DomandeEsatte + 1
End If
Case Is = "D"
OptRisposta4.BackColor = vbGreen
If OptRisposta4.Value <> True Then
If OptRisposta1.Value = True Then
OptRisposta1.BackColor = vbRed
ElseIf OptRisposta2.Value = True Then
OptRisposta2.BackColor = vbRed
ElseIf OptRisposta3.Value = True Then
OptRisposta3.BackColor = vbRed
End If
Else
DomandeEsatte = DomandeEsatte + 1
End If
End Select
If (LCase(Foglio1.Cells(RigaDomanda, 8)) <> "x") Then
DomandaDaVerificare = RigaDomanda
DomandeLette = DomandeLette + 1
Call ModificaFaccina
LblLette.Caption = CStr(DomandeLette)
LblEsatte.Caption = CStr(DomandeEsatte)
LblPercEsatte.Caption = CStr(PercentualeEsatte) & " %"
Foglio1.Cells(RigaDomanda, 8) = "x"
Foglio1.Range("H" & CStr(RigaDomanda), "H" & CStr(RigaDomanda)).HorizontalAlignment = xlHAlignCenter
End If
UltimaDomandaCasualeRisposta = RigaDomanda
Else
MsgBox "Selezionare almeno una risposta !", vbExclamation, "Attenzione"
End If
End Sub
Private Sub Esci_Click()
Call SalvaImpostazioniQuiz
Lavoro.Save
Application.DisplayAlerts = False
'ActiveWorkbook.Save
Application.DisplayAlerts = True
xChiudi = True
' SE VUOI CHIUDERE IL DOCUMENTO SUL QUALE _
STAI LAVORANDO E LASCIARE EXCEL APERTO _
TOGLI L 'APICINO ALLA SEGUENTE ISTRUZIONE _
E METTILO A QUELLA SUCCESSIVA
ActiveWorkbook.Close
' SE INVECE VUOI CHIUDERE COMPLETAMENTE EXCEL _
LASCIA LE COSE COSI'
'Application.Quit
End Sub
Private Sub FraAndamento_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub FraRiferimenti_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub Img10_Click()
End Sub
Private Sub LblCapEsatte_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblCapIndice_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblCapLette_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblCapNumero_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblCapPercEsatte_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblEsatte_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblLette_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub LblPercEsatte_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub OptCasuale_Click()
CmbIndice.Enabled = False
CmbNumero.Enabled = False
CmdVerificaRisposta.SetFocus
End Sub
Private Sub OptRisposta1_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub OptRisposta2_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub OptRisposta3_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub OptRisposta4_Click()
CmdVerificaRisposta.SetFocus
End Sub
Private Sub OptSequenziale_Click()
CmbIndice.Enabled = True
CmbNumero.Enabled = True
CmdVerificaRisposta.SetFocus
End Sub
Private Sub UserForm_Activate()
Dim Cont1 As Integer
Dim NumeroCasuale As Integer
Dim StrTemp As String * 1
Call VerificaVettoreDomande(IndiceDomanda)
Call CaricaImpostazioniQuiz
'Caricamento domanda casuale
If OptCasuale.Value = True Then
Me.MousePointer = 13
Do
Randomize Timer
NumeroCasuale = Int((DomandeTotali * Rnd) + 1)
StrTemp = Foglio1.Cells(NumeroCasuale, 8)
Loop While (LCase(StrTemp) = "x")
RigaDomanda = NumeroCasuale
Call LeggiDomanda(RigaDomanda)
Me.MousePointer = 0
End If
Call LeggiDomanda(RigaDomanda)
For Cont1 = 0 To UBound(IndiceDomanda.Indice)
CmbIndice.AddItem IndiceDomanda.Indice(Cont1)
Next Cont1
Call AggiornaCombo
Foglio3.Activate
Foglio3.Range("F22:F22").Select
CmdVerificaRisposta.SetFocus
End Sub
Private Sub UserForm_Terminate()
Call SalvaImpostazioniQuiz
Lavoro.Save
Application.DisplayAlerts = False
'ActiveWorkbook.Save
Application.DisplayAlerts = True
xChiudi = True
' SE VUOI CHIUDERE IL DOCUMENTO SUL QUALE _
STAI LAVORANDO E LASCIARE EXCEL APERTO _
TOGLI L 'APICINO ALLA SEGUENTE ISTRUZIONE _
E METTILO A QUELLA SUCCESSIVA
ActiveWorkbook.Close
' SE INVECE VUOI CHIUDERE COMPLETAMENTE EXCEL _
LASCIA LE COSE COSI'
'Application.Quit
End Sub
'--------------------
'Procedure e funzioni
'--------------------
- Codice: Seleziona tutto
Private Sub AggiornaCombo()
Dim Lettere As String * 2
Dim Numeri As String
Dim Cont1 As Integer
Dim Cont2 As Integer
Lettere = Mid$(LblNumDomanda.Caption, 1&, 2&)
Numeri = Mid$(LblNumDomanda.Caption, 3&)
For Cont1 = 0 To UBound(IndiceDomanda.Indice)
If Lettere = IndiceDomanda.Indice(Cont1) Then
CmbNumero.Clear
For Cont2 = 1 To IndiceDomanda.Numero(Cont1)
CmbNumero.AddItem Format$(Cont2, "00000")
Next Cont2
CmbIndice.ListIndex = Cont1
CmbNumero.ListIndex = CInt(Numeri) - 1
End If
Next Cont1
End Sub
Private Sub CaricaImpostazioniQuiz()
With Foglio2
RigaDomanda = RigaAssoluta(.Cells(2, 1))
DomandeLette = CInt(.Cells(2, 2))
DomandeEsatte = CInt(.Cells(2, 3))
If .Cells(2, 4) = "Sequenziale" Then
OptSequenziale.Value = True
ElseIf .Cells(2, 4) = "Casuale" Then
OptCasuale.Value = True
End If
End With
Call ModificaFaccina
LblLette.Caption = CStr(DomandeLette)
LblEsatte.Caption = CStr(DomandeEsatte)
LblPercEsatte.Caption = CStr(PercentualeEsatte) & " %"
End Sub
Private Sub SalvaImpostazioniQuiz()
Dim Lettere As String * 2
Dim Numeri As String
Lettere = Mid$(LblNumDomanda.Caption, 1&, 2&)
Numeri = Mid$(LblNumDomanda.Caption, 3&)
If RigaDomanda < DomandeTotali Then
Numeri = Format$(CInt(Numeri) + 1, "00000")
End If
With Foglio2
.Cells(2, 1) = (Lettere & Numeri)
.Cells(2, 2) = CStr(DomandeLette)
.Cells(2, 3) = CStr(DomandeEsatte)
If OptSequenziale.Value = True Then
.Cells(2, 4) = "Sequenziale"
ElseIf OptCasuale.Value = True Then
.Cells(2, 4) = "Casuale"
End If
End With
End Sub
Private Sub LeggiDomanda(ByVal NumDomanda As Integer)
With Foglio1
LblNumDomanda.Caption = .Cells(NumDomanda, 1)
LblDomanda.Caption = .Cells(NumDomanda, 2)
OptRisposta1.Caption = .Cells(NumDomanda, 3)
OptRisposta2.Caption = .Cells(NumDomanda, 4)
OptRisposta3.Caption = .Cells(NumDomanda, 5)
OptRisposta4.Caption = .Cells(NumDomanda, 6)
End With
End Sub
Private Function RigaAssoluta(ByVal CodiceDomanda As String) As Integer
Dim Lettere As String * 2
Dim Numeri As String
Dim Cont1 As Integer
Lettere = Mid$(CodiceDomanda, 1&, 2&)
Numeri = Mid$(CodiceDomanda, 3&)
For Cont1 = 0 To UBound(IndiceDomanda.Indice)
If Lettere = IndiceDomanda.Indice(Cont1) Then
RigaAssoluta = RigaAssoluta + CInt(Numeri)
Exit For
Else
RigaAssoluta = RigaAssoluta + IndiceDomanda.Numero(Cont1)
End If
Next Cont1
End Function
Private Sub ModificaFaccina()
If (DomandeLette > 0) Then
If (DomandeEsatte > 0) Then
PercentualeEsatte = CInt(Round(DomandeEsatte / DomandeLette, 2&) * 100)
Else
PercentualeEsatte = 0
End If
Call NascondiFaccine
If (PercentualeEsatte >= 90) Then
Img10.Visible = True
ElseIf (PercentualeEsatte >= 80) And (PercentualeEsatte < 90) Then
Img9.Visible = True
ElseIf (PercentualeEsatte >= 70) And (PercentualeEsatte < 80) Then
Img8.Visible = True
ElseIf (PercentualeEsatte >= 60) And (PercentualeEsatte < 70) Then
Img7.Visible = True
ElseIf (PercentualeEsatte >= 50) And (PercentualeEsatte < 60) Then
Img6.Visible = True
ElseIf (PercentualeEsatte >= 40) And (PercentualeEsatte < 50) Then
Img5.Visible = True
ElseIf (PercentualeEsatte >= 30) And (PercentualeEsatte < 40) Then
Img4.Visible = True
ElseIf (PercentualeEsatte >= 20) And (PercentualeEsatte < 30) Then
Img3.Visible = True
ElseIf (PercentualeEsatte >= 10) And (PercentualeEsatte < 20) Then
Img2.Visible = True
ElseIf (PercentualeEsatte < 10) Then
Img1.Visible = True
End If
Else
Call NascondiFaccine
End If
End Sub
Private Sub NascondiFaccine()
Img1.Visible = False
Img2.Visible = False
Img3.Visible = False
Img4.Visible = False
Img5.Visible = False
Img6.Visible = False
Img7.Visible = False
Img8.Visible = False
Img9.Visible = False
Img10.Visible = False
End Sub
Private Sub AzzeraOpzioni()
OptRisposta1.BackColor = &H8000000F
OptRisposta2.BackColor = &H8000000F
OptRisposta3.BackColor = &H8000000F
OptRisposta4.BackColor = &H8000000F
OptRisposta1.Value = False
OptRisposta2.Value = False
OptRisposta3.Value = False
OptRisposta4.Value = False
End Sub
Private Sub VerificaVettoreDomande(ByRef IndiceDomanda As Domanda)
Const RigheVuoteFineDomande As Integer = 5
Dim Cont1 As Integer
Dim Cont2 As Integer
Dim ContFineDomande As Integer
Dim Cella As String
Dim Totale As Integer
Dim Parziale As Integer
Dim FineDomande As Boolean
Cont1 = 5
Do
Cella = Foglio2.Cells(Cont1, 2)
If Len(Cella) = 0 Then
FineDomande = True
Else
Totale = Totale + CInt(Cella)
Cont1 = Cont1 + 1
End If
Loop Until FineDomande = True
FineDomande = False
DomandeTotali = CInt(Foglio2.Cells(2, 5))
If ((DomandeTotali = 0) Or (DomandeTotali < Totale) Or (Totale = 0)) Then
'Elimina la tabella degli indici nella scheda Impostazioni
Do
Cella = Foglio2.Cells(5, 1)
If (Len(Cella) > 0) Then
Foglio2.Range("A5:B5").EntireRow.Delete (xlShiftUp)
End If
Loop Until (Len(Cella) = 0)
'Esegue l'analisi della scheda Domande
Me.MousePointer = 13
Totale = 0
Cont1 = 1
Cont2 = 5
Do
'Elimina eventuali righe vuote nella scheda Domande
Cella = Foglio1.Cells(Cont1, 1)
If Len(Cella) = 0 Then
Foglio1.Range("A" & CStr(Cont1)).EntireRow.Delete (xlShiftUp)
ContFineDomande = ContFineDomande + 1
If ContFineDomande = RigheVuoteFineDomande Then
FineDomande = True
End If
Else
'Ricerca gli indici delle domande e li aggiunge nella scheda Impostazioni
If Left(Cella, 2&) <> Foglio2.Cells(Cont2 - 1, 1) Then
Foglio2.Cells(Cont2, 1) = Left$(Cella, 2&)
Foglio2.Range("A" & CStr(Cont2), "B" & CStr(Cont2)).BorderAround (xlContinuous)
Foglio2.Range("A" & CStr(Cont2), "B" & CStr(Cont2)).HorizontalAlignment = xlHAlignCenter
If Cont2 > 5 Then
Foglio2.Cells(Cont2 - 1, 2) = CStr(Parziale)
End If
Cont2 = Cont2 + 1
Parziale = 0
End If
Parziale = Parziale + 1
Totale = Totale + 1
Cont1 = Cont1 + 1
End If
Loop Until FineDomande = True
'Azzera la statistica e aggiorna alcuni dati nella scheda Impostazioni
Foglio2.Cells(2, 1) = Foglio1.Cells(1, 1)
Foglio2.Cells(2, 2) = "0"
Foglio2.Cells(2, 3) = "0"
Foglio2.Cells(2, 5) = CStr(Totale)
DomandeTotali = Totale
Foglio2.Cells(Cont2 - 1, 2) = CStr(Parziale)
Me.MousePointer = 0
End If
'Riempimento del vettore IndiceDomanda
ReDim IndiceDomanda.Indice(0)
ReDim IndiceDomanda.Numero(0)
Cont1 = 5
Do
Cella = Foglio2.Cells(Cont1, 1)
If Len(Cella) = 0 Then
FineDomande = True
Else
IndiceDomanda.Indice(Cont1 - 5) = Cella
Cella = Foglio2.Cells(Cont1, 2)
IndiceDomanda.Numero(Cont1 - 5) = CInt(Cella)
Cont1 = Cont1 + 1
ReDim Preserve IndiceDomanda.Indice(UBound(IndiceDomanda.Indice) + 1)
ReDim Preserve IndiceDomanda.Numero(UBound(IndiceDomanda.Numero) + 1)
End If
Loop Until FineDomande = True
If (UBound(IndiceDomanda.Indice) > 0) Then
ReDim Preserve IndiceDomanda.Indice(UBound(IndiceDomanda.Indice) - 1)
ReDim Preserve IndiceDomanda.Numero(UBound(IndiceDomanda.Numero) - 1)
End If
End Sub