在Excel-VBA中正确设置`If Condition`和正确使用`Loop Structure`

Question

我的工作簿有三张表格， Questions，Answers和Incorrect Mappings。

在问题表： Column A是Question_Id。

Column B：Answer_Type有中值：真/假，彼此，多项目，的CheckBox，事件。

Column C：Answer_Id（一个或多个'数值'）用分号分隔。

在问答表：

Column A是Answer_Id。 （很少或全部答案编号为Questions工作表将在此处列出，每个都在一行中）。

Column B是Frequency;其具有的值，例如：

基于事件，年，半年，季刊。

问题与答案表链接在Answer_Id列。

要求： 如果有任何问题ID具有 '答案类型'，如真/假，彼此多项目，复选框;然后在 Answers表中针对此Answer_Id的表单不应具有针对此Answer_Id的频率Event Based。 即如果Answer_Type是“事件”只然后，针对它频率应基于事件

在Questions片的不正确的映射应该被发送到Incorrect Mappings片为超链接到“问题”表。 我已经写了下面的代码：

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答案工作。