Creare una Macro per test concorsi in Excel

clandestino83, 19/01/2012 11.14:

---

si credo che si possa fare l'unica cosa, devi spiegarci comè strutturato il tuo file se alleghi un'esempio possiamo vedere meglio cosa fare

---

Testo nascosto - clicca qui

Public myQMsg$, myQTitle$, myQDefault$, myQResp$


'*** Change your Test Title Here! ***
Public Const myTestTitle$ = "Welcome to the Test One Exam!"
'********************************************************************


Private Sub myLoadQuestions()
Dim tSht%, eSht%, tSht2%, eSht2%, tShts1%, eShts1%, tShts2%, eShts2%
Dim myMsg$, myTitle$, myDefault$, myResp$
Dim ws As Worksheet, myNewSht As Worksheet

myTitle = "Change this Tests Title?"

On Error GoTo mySkip
If Sheets("Start").Range("A3").Value <> "" Then
myDefault = Sheets("Start").Range("A3").Value
Else

mySkip:
myDefault = myTestTitle
End If

myMsg = "The current test title is:" & vbLf & vbLf & _
myDefault & vbLf & vbLf & _
"If you want to change this tests title," & vbLf & _
"do so now!"

myResp = InputBox(myMsg, myTitle, myDefault)


tSht = Worksheets.Count

For Each ws In Worksheets
eSht = eSht + 1

If ws.Name = "Start" Then GoTo gotSht
If tSht = eSht Then GoTo mkSht
Next ws

mkSht:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Start"
Sheets("Start").Move After:=Sheets(tSht + 1)

gotSht:
Sheets("Start").Select
Sheets("Start").Range("A3").Select

With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 18
End With

Sheets("Start").Range("A3").Value = myResp

On Error GoTo myAdd
ActiveSheet.Shapes("myButton").Delete

myAdd:
With Sheets("Start").Shapes.AddShape(msoShapeBevel, 172, 105, 90, 33)
.Name = "myButton"
End With

ActiveSheet.Shapes("myButton").Select

With Selection.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 26
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 18
.Line.BackColor.RGB = RGB(255, 255, 255)
End With

ActiveSheet.Shapes("myButton").Select
Selection.Characters.Text = "Start"

With Selection.Characters(Start:=1, Length:=5).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 14
.ColorIndex = 11
End With

ActiveSheet.Shapes("myButton").Select

With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.AutoSize = False
End With

ActiveSheet.Shapes("myButton").Select
Selection.onAction = "myDoQuestions"
Range("A1").Select

'********************************************************************

tSht2 = Worksheets.Count

For Each ws In Worksheets
eSht2 = eSht2 + 1

If ws.Name = "Info" Then GoTo gotShtB
If tSht2 = eSht2 Then GoTo mkShtB
Next ws

mkShtB:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Info"
Sheets("Info").Move After:=Sheets(tSht2 + 1)

gotShtB:
Sheets("Info").Select
Sheets("Info").Range("A1").Select

'********************************************************************

tShts1 = Worksheets.Count

For Each ws In Worksheets
eShts1 = eShts1 + 1

If ws.Name = "Questions" Then GoTo gotSht1
If tShts1 = eShts1 Then GoTo mkSht1
Next ws

mkSht1:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Questions"
Sheets("Questions").Move After:=Sheets(tShts1 + 1)

gotSht1:
If Sheets("Questions").Visible = False Then _
Sheets("Questions").Visible = True

Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Columns("A:A").ColumnWidth = 128
Sheets("Questions").Range("A1").Select

'********************************************************************

tShts2 = Worksheets.Count

For Each ws In Worksheets
eShts2 = eShts2 + 1

If ws.Name = "Answers" Then GoTo gotSht2
If tShts2 = eShts2 Then GoTo mkSht2
Next ws

mkSht2:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Answers"
Sheets("Answers").Move After:=Sheets(tShts2 + 1)

gotSht2:
If Sheets("Answers").Visible = False Then _
Sheets("Answers").Visible = True

Sheets("Answers").Select
Sheets("Answers").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Answers").Range("A1").Select

Sheets("Questions").Select

'********************************************************************

For Each ws In Worksheets
If ws.Name = "Start" Or ws.Name = "Info" Or ws.Name = "Questions" Or ws.Name = "Answers" Then
GoTo myNotDel
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If

myNotDel:
Next ws

Call displayLoadInst


End Sub

Sub displayLoadInst()

Application.MacroOptions Macro:="displayLoadInst", Description:= _
"Show the Load Questions Instructions!", ShortcutKey:="i"

MsgBox "Instructions: Type your Questions in Column: A," & vbLf & _
"Starting in Row: 1, Cell: A1 of the Sheet Named ""Questions""" & vbLf & _
"One Question per Row-Cell!" & vbLf & vbLf & _
"Like: On Sheet ""Questions"" Cell: ""A1"" Add:" & vbLf & vbLf & _
"Select the best answer: A, B, C, D or E. [Note: For a new line in your Question, Hit: Alt + Enter]" & vbLf & _
"1 + 1 = ? [Note: For a BLANK Line in your Question, Hit: Alt + Enter, two times!]" & vbLf & vbLf & _
" A). 1.1, B). 1, C). 2, D). 4, E). None of these answers! [Note: Add Spacing as needed!] " & vbLf & _
vbLf & vbLf & "Then Add Each Question's Answer to the Same Cell on the Sheet Named: ""Answers""" & _
vbLf & vbLf & "Like for the Sample Question Above on Sheet ""Answers"" Cell: A1:" & vbLf & "2" & _
vbLf & vbLf & "Note: To Re-Show these Instructions from any sheet, Hit: Ctrl + i" & vbLf & vbLf & _
"Note: To Re-Run the ""Load Questions Utility"" Hit: Ctrl + q" & vbLf & _
"Only Sheets: Start, Info, Questions and Answers, will remain all others are deleted!" & vbLf & _
"Sheet: ""Start"" is the Main Menu Application. ""Info"" is where you add supplemental material." & _
vbLf & "All other Sheets are ""Hidden when you Hit: Ctrl + h, To show all Sheets, Hit: Ctrl + q"

Call displayAppInst

End Sub

Sub displayAppInst()

Application.MacroOptions Macro:="displayAppInst", Description:= _
"Show the Application Instructions!", ShortcutKey:="a"

MsgBox "Application Instructions:" & vbLf & _
"Use the ""Start"" Sheet to Navagate!" & vbLf & vbLf & _
"Use the ""Info"" Sheet to Add Supplemental Question: Materials and Support Information!" & vbLf & _
vbLf & "Note: To Re-Show these ""Application Instructions"" at any Time, Hit: Ctrl + a" & vbLf
End Sub

Private Sub myQsMsg()

myQResp = UCase(InputBox(myQMsg, myQTitle, myQDefault))

End Sub

Sub myDoQuestions()
Dim myBot&, n%, a%

myBot = Sheets("Questions").Range("A65536").End(xlUp).Row

Set myRng = Sheets("Questions").Range("A1:A" & myBot)

For Each q In myRng
n = q.Row

myQTitle = "Question" & n & "!"
myQMsg = q.Value
myQDefault = ""

myAgain:
Call myQsMsg

If Len(myQResp) <> 1 Then
MsgBox "Your answer must be one letter!"
GoTo myAgain
End If

If myQResp = UCase(Sheets("Answers").Range("A" & n).Value) Then a = (a + 1)
Next q

If myBot = n Then
MsgBox "Your Score: " & a & " right out of: " & myBot & " questions!"
Sheets("Answers").Range("A" & myBot + 1).Value = "Score: " & a & "/" & myBot
End If
End Sub

Sub myHide()

On Error GoTo myErr
Application.MacroOptions Macro:="myHide", Description:= _
"Hide Application Data Sheets!", ShortcutKey:="h"

Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 2
Sheets("Questions").Range("A1").Select

If Sheets("Questions").Visible = True Then _
Sheets("Questions").Visible = False

Sheets("Answers").Select
Sheets("Answers").Columns("A:A").Select
Selection.Font.ColorIndex = 2
Sheets("Answers").Range("A1").Select

If Sheets("Answers").Visible = True Then _
Sheets("Answers").Visible = False

Sheets("Start").Select
Sheets("Start").Range("A1").Select
GoTo myEnd

myErr:
MsgBox "You can only hide once!" & vbLf & vbLf & _
"You must: Ctrl + q" & vbLf & "first or Run the Macro: ""getAccess"""

myEnd:
End Sub

Sub getAccess()
Dim myTitle$, myMsg$, myDefault$, myPW$, myResp$

'**** Change the PassWord Here!********************************
'****************** vvvvvvvvvvvvvv *************************************
myPassWord = "Admin" 'Note: the PW is case sensitive!
'***********************************************************************
Application.MacroOptions Macro:="getAccess", Description:= _
"Load Questions!", ShortcutKey:="q"

myTitle = "Get Access to this Application?"
myMsg = "Please type your PassWord," & vbLf & _
"to Gain Access to your Data!"
myDefault = ""

myResp = InputBox(myMsg, myTitle, myDefault)

If myResp = myPassWord Then
Call myLoadQuestions

Else
MsgBox "Error: Wrong PassWord!"
End If
End Sub

Testo nascosto - clicca qui

---

Ora la mia domanda è:
il programmino come tu lo hai strutturato va benissimo ma se in un foglio, ad esempio EDU, inserisco 1200 domande (che è il numero totale di quelle di EDU) ovviamente non mi considererà tutte quelle domande che vanno dalla 52 alle 1200 giusto? se si, che parte dell'algoritmo dovrei modificare per gestire il range di domande al quale far riferimento?

---