Hi,

I've changed the code to allow for different question-chain lengths so
that the loop is exited after the user answers a chain of questions
that is less than the greatest level in the code and the answers to
those questions is enough for a decision to be made.

The pattern followed by the code is...

If the answer to Question N is Yes then Question 2N is asked.
If the answer to Question N is No then Question 2N + 1 is asked

If a decision can be made after the User answers Question N with a Yes,
then in the code make Question 2N an empty string (strQuestion(2N) =
"").
If a decision can be made after the user answers Question N with a No,
then in the code make Question 2N + 1 an empty string (strQuestion(2N
+ 1) = "")

Now there is no need to change the code to a lower maximum number of
levels.
Changes only need to be made if you need more than 6 levels. To
increase the maximum number of levels change the value of iMaxLevel and
add the additional questions (Total number of questions is
(2^(iMaxLevel) - 1)

Below is the Workbook_Open version. The Function (hasn't changed) can
also be pasted in the ThisWorkbook module.

Private Sub Workbook_Open()
Dim I As Integer
Dim strQuestion()
Dim strAnswer()
Dim strAnswerHistory As String
Dim iQuestionHistory() As Integer
Dim Level As Byte
Dim Next_Question As Integer
Dim iMaxLevel As Byte
iMaxLevel = 6
ReDim strQuestion(1 To (2 ^ iMaxLevel) - 1)
ReDim strAnswer(1 To (2 ^ iMaxLevel) - 1)
strQuestion(1) = "Q1?"
strQuestion(2) = "Q2?"
strQuestion(3) = "Q3?"
strQuestion(4) = "Q4?"
strQuestion(5) = "Q5?"
strQuestion(6) = "Q6?"
strQuestion(7) = "Q7?"
strQuestion(8) = "Q8?"
strQuestion(9) = "Q9?"
strQuestion(10) = "Q10?"
strQuestion(11) = "Q11?"
strQuestion(12) = "Q12?"
strQuestion(13) = "Q13?"
strQuestion(14) = "Q14?"
strQuestion(15) = "Q15?"
strQuestion(16) = "Q16?"
strQuestion(17) = "Q17?"
strQuestion(18) = "Q18?"
strQuestion(19) = "Q19?"
strQuestion(20) = "Q20?"
strQuestion(21) = "Q21?"
strQuestion(22) = "Q22?"
strQuestion(23) = "Q23?"
strQuestion(24) = "Q24?"
strQuestion(25) = "Q25?"
strQuestion(26) = "Q26?"
strQuestion(27) = "Q27?"
strQuestion(28) = "Q28?"
strQuestion(29) = "Q29?"
strQuestion(30) = "Q30?"
strQuestion(31) = "Q31?"
strQuestion(32) = "Q32?"
strQuestion(33) = "Q33?"
strQuestion(34) = "Q34?"
strQuestion(35) = "Q35?"
strQuestion(36) = "Q36?"
strQuestion(37) = "Q37?"
strQuestion(38) = "Q38?"
strQuestion(39) = "Q39?"
strQuestion(40) = "Q40?"
strQuestion(41) = "Q41?"
strQuestion(42) = "Q42?"
strQuestion(43) = "Q43?"
strQuestion(44) = "Q44?"
strQuestion(45) = "Q45?"
strQuestion(46) = "Q46?"
strQuestion(47) = "Q47?"
strQuestion(48) = "Q48?"
strQuestion(49) = "Q49?"
strQuestion(50) = "Q50?"
strQuestion(51) = "Q51?"
strQuestion(52) = "Q52?"
strQuestion(53) = "Q53?"
strQuestion(54) = "Q54?"
strQuestion(55) = "Q55?"
strQuestion(56) = "Q56?"
strQuestion(57) = "Q57?"
strQuestion(58) = "Q58?"
strQuestion(59) = "Q59?"
strQuestion(60) = "Q60?"
strQuestion(61) = "Q61?"
strQuestion(62) = "Q62?"
strQuestion(63) = "Q63?"
Do While Level < iMaxLevel
Level = Level + 1
If Level = 1 Then Next_Question = 1
ReDim Preserve iQuestionHistory(Level)
iQuestionHistory(Level) = Next_Question
strAnswer(Next_Question) = _
MsgBox(strQuestion(Next_Question), 3)
Select Case strAnswer(Next_Question)
Case 6
strAnswerHistory = strAnswerHistory & "1"
Case 7
strAnswerHistory = strAnswerHistory & "0"
Case 2
Exit Sub
End Select
Next_Question = _
next_question_number(strAnswerHistory)
If Level < iMaxLevel Then
If strQuestion(Next_Question) = "" Then
Exit Do
End If
End If
Loop
For I = 1 To Level
MsgBox strQuestion(iQuestionHistory(I)) & "..." _
& IIf(Mid(strAnswerHistory, I, 1) = "1", "Yes", "No")
Next
End Sub

Public Function next_question_number _
(strInput As String) As Integer
Dim iDigits As Integer
iDigits = Len(strInput)
Dim iBinaryToInteger As Integer
Dim I As Integer
For I = 1 To iDigits
Select Case Mid(strInput, I, 1)
Case "1"
Case "0"
iBinaryToInteger = iBinaryToInteger _
+ 2 ^ (iDigits - I)
End Select
next_question_number = 2 ^ iDigits _
+ iBinaryToInteger
Next
End Function

Ken Johnson