vba - 正确的 `If Condition` 以及在 Excel-VBA 中正确使用 `Loop Structure`

Question

我的工作簿有三张纸，即； 问题、答案和不正确的映射。

在问题表中:A 列 是Question_Id。

B 列:Answer_Type 的值包括:True/False、One another、Multi项目、复选框、事件。

C 列:Answer_Id(一个或多个“数值”)，以分号分隔。

在答案表中:

A 列 是Answer_Id。(Questions 表的部分或全部答案 ID 将在此处列出，每个答案 ID 都在一行上)。

B 列 是频率；其值如下:

基于事件、每年、半年、每季度。

问题和解答表链接在 Answer_Id 列上。

要求:如果任何问题 ID 具有“答案类型”，例如 True/False、One other、Multi item、CheckBoxes；然后答案 Id 反对它Answers 表不应针对此类 Answer_Id 具有基于事件的频率。即，如果 Answer_Type 为“事件”，则其频率应为基于事件

问题表中的错误映射应作为“问题”表的超链接发送到错误映射表。我编写了以下代码:

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

当我运行上面的代码时，我确实得到了混合输出(不正确的输出)。

一步步编写代码并一步步调试后，我感觉错误在注释行处 这个 If 条件是否应该更改为其他内容？或者在它上面的行。

谁能告诉我，我必须在什么条件下改变它？

(此外，我需要更改循环结构，以便在 In Correct Mappings 表中仅获得一次不正确的映射，但这是第二优先级)

Answer 1

通过引入Scripting.Dictionary，您可以轻松查找答案工作表上的键。对象。

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

我添加了一项检查，以确保在问题工作表中找到的答案 ID 实际上存在于答案工作表中。