Proper `If Condition` and proper use of `Loop Structure` in Excel-VBA - vba

Question

My Workbook has three sheets, Namely; Questions, Answers and Incorrect Mappings.
In Questions Sheet:
Column A is Question_Id.
Column B: Answer_Type has value among : True/False, One another, Multi item, CheckBoxes, Event.
Column C: Answer_Id (One or More 'Numeric Values') separated with Semicolon.
In Answers Sheet:
Column A is Answer_Id.
(Few or all Answer IDs of Questions sheet will be listed here, each on a single row).
Column B is Frequency; which has values such as:
Event Based, Yearly, Half Yearly, Quarterly.
The Questions and Answers sheet are linked on Answer_Id column.
Requirement:
If any Question Id has 'Answer Types' such as True/False, One another, Multi item, CheckBoxes; then Answer Id's against it in
Answers sheet should not have frequency Event Based against such Answer_Id.
i.e. If Answer_Type is 'Event' then only, frequency against it should be Event Based
The incorrect mappings in Questions sheet should be sent to Incorrect Mappings sheet as hyperlinks to 'Questions' Sheet.
I've written the following code:
Dim shname, strstr, strErr, stString As String
Dim stArray() As String
Dim AnsIds1 As Range
Dim celadr, celval, AnsId1, AnsId2, questionType As Variant
Dim LastRow, LastRowSheet2 As Long
LastRow = Sheets("Questions").Cells(Rows.Count, 2).End(xlUp).Row
LastRowSheet2 = Sheets("Answers").Cells(Rows.Count, 2).End(xlUp).Row
For Each questionType In Worksheets("Questions").Range("B2:B" & LastRow)
celadr = questionType.Address
celval = questionType.Value
If Len(celval) >= 1 Then
If InStr(1, ("TRUE/FALSE,ONE ANOTHER,MULTI ITEM,CHECKBOXES,"), UCase(celval) & ",") >= 1 Then
For Each AnsIds1 In Worksheets("Questions").Range("C2:C" & LastRow)
stString = AnsIds1
stArray() = Split(stString, ";")
For Each AnsId1 In stArray()
For Each AnsId2 In Worksheets("Answers").Range("A2:A" & LastRowSheet2).Cells
If Trim(AnsId1) = Trim(AnsId2) Then
If Trim(UCase(AnsId2.Offset(0, 1).Value)) = "EVENT BASED" Then 'Is this If condition should be changed to something else?
AnsIds1.Interior.Color = vbRed
celadr = AnsIds1.Address
Sheets("Questions").Select
shname = ActiveSheet.Name
Sheets("Incorrect Mappings").Range("A65536").End(xlUp).Offset(1, 0).Value = AnsId2 & " Should not have Event based frequency"
strstr = "'" & shname & "'!" & Range(celadr).Address(0, 0)
Sheets("Incorrect Mappings").Hyperlinks.Add Anchor:=Sheets("Incorrect Mappings").Range("A65536").End(xlUp), Address:="", SubAddress:=strstr
End If
End If
Next
Next
Next
End If
End If
Next
When I run the above code, I do get the mixed output (an incorrect output).
After writing the code step by step and debugging it step by step, I feel the mistake is at line commented as
Is this If condition should be changed to something else? or at the line above it.
Can someone tell me, to what condition I've to change it?.
(Also, I need to change loop structure to get incorrect mappings only once in Incorrect Mappings sheet, but it's a second priority)

Answer 1

Your lookup to the keys on the Answers worksheet could be eased with the introduction of a Scripting.Dictionary object.
Sub question_Check_by_Dictionary()
Dim questionType As Range
Dim v As Long, vAIDs As Variant, d As Long, dict As Object
'load the dictionary with the answer types
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
With Worksheets("Answers")
For d = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
dict.Item(CStr(.Cells(d, 1).Value2)) = .Cells(d, 2).Value2
Next d
End With
'reset the Questions worksheet
With Worksheets("Questions")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp)).Interior.Pattern = xlNone
End With
'reset the Incorrect Mappings worksheet
With Worksheets("Incorrect Mappings")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Clear
End With
With Worksheets("Questions")
For Each questionType In .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
If Not CBool(InStr(1, questionType.Value2, "event", vbTextCompare)) Then
vAIDs = Split(questionType.Offset(0, 1), Chr(59)) 'split on semi-colon
For v = LBound(vAIDs) To UBound(vAIDs)
If dict.exists(vAIDs(v)) Then
If CBool(InStr(1, dict.Item(CStr(vAIDs(v))), "event", vbTextCompare)) Then
questionType.Resize(1, 3).Offset(0, -1).Interior.Color = vbRed
With Sheets("Incorrect Mappings")
.Hyperlinks.Add Anchor:=.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0), _
Address:="", SubAddress:=questionType.Address(external:=True), _
ScreenTip:="click to go to rogue question", _
TextToDisplay:="Question " & questionType.Offset(0, -1).Value2 & _
" should not have Event based frequency (" & _
vAIDs(v) & ")."
End With
End If
Else
questionType.Resize(1, 3).Offset(0, -1).Interior.Color = vbYellow
With Sheets("Incorrect Mappings")
.Hyperlinks.Add Anchor:=.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0), _
Address:="", SubAddress:=questionType.Address(external:=True), _
ScreenTip:="click to go to rogue question", _
TextToDisplay:="Question " & questionType.Offset(0, -1).Value2 & _
" references an unknown Answer ID (" & _
vAIDs(v) & ")."
End With
End If
Next v
End If
Next questionType
End With
End Sub
I've added a check to ensure that the answer ID found in the Questions worksheet actually exists in the Answers worksheet.