Question

我的工作簿有三张，即; Questions，Answers和Incorrect Mappings。

在问题表格中： Column A为Question_Id。

Column B：Answer_Type具有以下价值：真/假，彼此，多项，< strong> CheckBoxes ，活动。

Column C：Answer_Id（一个或多个＆＃39;数字值＆＃39;）用分号分隔。

在答案表格中：

Column A是Answer_Id。（此处列出Questions表的少数或全部答案ID，每个单独一行。

Column B是Frequency;其值如：

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

问题与解答表已链接到Answer_Id列。

要求：如果任何问题ID具有“答案类型”和“＃39;如真/假，彼此，多项，CheckBoxes;然后回答我的反对意见对于此类Answer_Id，Answers工作表不应具有频率Event Based。即如果Answer_Type是＆＃39;事件＆＃39;那么，对它的频率应该是基于事件

Questions表格中的不正确映射应作为超链接发送到Incorrect Mappings表格，作为问题＆＃39;片。我写了以下代码：

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

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

在逐步编写代码并逐步调试之后，我觉得这个错误在线评论为 Is this If condition should be changed to something else?或在其上方的一行。

有人可以告诉我，我改变它的条件是什么？

（另外，我需要更改循环结构以在Incorrect 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实际存在于答案工作表中。

正确`If Condition`并正确使用Excel-VBA中的`Loop Structure`

1 个答案: