使用脚本字典找到使用Excel VBA

Question

我试图在某种程度上使用Scripting Dictionary为能够找到并最终突出相同的值或相同的值，其中一组在A列重复的号码组/亮点跳跃存在不一致性（即，两个相同值或相同值组之间的空白或不同值）。通常，这些相同的价值观将重复，但是当他们不要重蹈我想要赶上是一起（请参见下面从我以前的帖子所采取的示例图像）。

有些情况下，希望能帮助这使一些更有意义：

这是各种各样的后续我以前的问题here之一。我有一个条件格式公式：

=NOT(AND(IFERROR(COUNTIF(OFFSET(A1,0,0,-COUNTIF($A$1:$A1,A2)),A2),0)=IFERROR(COUNTIF($A$1:$A1,A2),0),IFERROR(COUNTIF(OFFSET(A3,0,0,COUNTIF($A3:$A$5422,A2)),A2),0)=IFERROR(COUNTIF($A3:$A$5422,A2),0),A2<>"")) 

这是完美的。然而，在接受该公式为这个问题的答案前面的问题后，我的修修补补，我意识到，使用任何类型的，因为我通常处理（15000+行与140个一致列）的数据量的条件格式是一个非常缓慢的努力，无论是当应用公式和事后过滤/调整时。我也尝试通过“帮手列”路线来应用这个公式，但毫不奇怪，这同样缓慢。

所以，我在哪里现在：

从本质上讲，我试图把这种配方成片的代码，做同样的事情，但更有效的，因此，这就是我开始思考使用Scripting Dictionary作为加速我的代码执行时间的一种方式。我列出了一些步骤，所以我知道我需要做什么。但是，我觉得我错误地执行了，这就是为什么我在这里寻求帮助。以下是我在使用Scripting Dictionary尝试完成突出与我想通了，我需要做的，完成任务的步骤沿A柱不一致（我的目标列）：

'dump column A into Array 
'(Using Scripting.Dictionary) While cycling through check if duplicate 
'IF duplicate check to make sure there is the same value either/or/both in the contiguous slot before/after the one being checked 
'If not, then save this value (so we can go back and highlight all instances of this value at the end) 
'Cycle through all trouble values and highlight all of their instances. 

Sub NewandImprovedXIDCheck() 
    Dim d As Long, str As String, columnA As Variant 
    Dim dXIDs As Object 

    Application.ScreenUpdating = False 

    Set dXIDs = CreateObject("Scripting.Dictionary") 
    dXIDs.comparemode = vbTextCompare 

    With ActiveSheet 
     With .Cells(1, 1).CurrentRegion 
      With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 
       '.Value2 is faster than using .Value 
       columnA = .Columns(1).Value2 
       For d = LBound(columnA, 1) To UBound(columnA, 1) 
        str = columnA(d, 1) 
        If dXIDs.exists(str) Then 
        'the key exists in the dictionary 
         'Check if beside its like counterparts 
         If Not UBound(columnA, 1) Then 
          If (str <> columnA(d - 1, 1) And str <> columnA(d + 1, 1)) Or str <> columnA(d - 1, 1) Or str <> columnA(d + 1, 1) Then 
           'append the current row 
           dXIDs.Item(str) = dXIDs.Item(str) & Chr(44) & "A" & d 
          End If 
         End If 
        Else 
         'the key does not exist in the dictionary; store the current row 
         dXIDs.Add Key:=str, Item:="A" & d 
        End If 
       Next d 

       'reuse a variant var to provide row highlighting 
       Erase columnA 
       For Each columnA In dXIDs.keys 
        'if there is more than a single cell address, highlight all 
        If CBool(InStr(1, dXIDs.Item(columnA), Chr(44))) Then _ 
         .Range(dXIDs.Item(columnA)).Interior.Color = vbRed 
       Next columnA 
      End With 
     End With 
    End With 

    dXIDs.RemoveAll: Set dXIDs = Nothing 

    Application.ScreenUpdating = True 

End Sub 

我觉得我的逻辑在我的代码执行过程中出错了，但似乎无法确定在哪里或如何纠正它。任何帮助将不胜感激。如果你可以提供任何类型的代码片段，这也是一个很大的帮助。

Answer 1

这里有一个办法：

Sub HiliteIfGaps() 

    Dim rng As Range, arr, r As Long, dict As Object, v 
    Dim num As Long, num2 As Long 

    Set dict = CreateObject("scripting.dictionary") 

    With ActiveSheet 
     Set rng = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)) 
    End With 

    arr = rng.Value 
    For r = 1 To UBound(arr, 1) 
     v = arr(r, 1) 
     If Len(v) > 0 Then 
      If Not dict.exists(v) Then 
       num = Application.CountIf(rng, v) 'how many in total? 
       'all where expected? 
       num2 = Application.CountIf(rng.Cells(r).Resize(num, 1), v) 
       dict.Add v, (num2 < num) 
      End If 
      If dict(v) Then rng.Cells(r).Interior.Color = vbRed 
     Else 
      'highlight blanks 
      rng.Cells(r).Interior.Color = vbRed 
     End If 
    Next r 

End Sub 

编辑：每一个新的价值被发现的时间（即在字典中没有的话），然后取计数有多少值的总有在范围被检查。如果所有这些值是连续的，然后他们都应该在范围rng.Cells(r).Resize(num, 1)发现：如果我们发现少高于预期（NUM2 < NUM）则意味着该值不连续，所以我们插入真到该值的字典项，并开始在列中突出显示该值。

Answer 2

@Tim威廉姆斯的做法做的工作完美！我只发一个轻微改变（以适应我的需要）。我改变

.Cells(.Rows.Count, 1).End(xlUp)到.Range("A" & .UsedRange.Rows.count)

正因为存在其中最底排（的）可能遗漏值（空白）实例，在这种情况下，我觉得足够安全使用.UsedRange引用，因为这个片段代码是在我的整个宏中运行的第一个代码之一，所以它（.UsedRange）更可能是准确的。我还添加了一个Boolean运算符（xidError，设置为False），只要我们需要突出显示，就将其更改为True。在完成循环遍历Array后，我检查xidError，如果为True，则提示用户修复错误，然后结束整个宏，因为在纠正此特定错误之前没有用处。

If xidError Then 
    'Prompt User to fix xid problem 
    MsgBox ("XID Error. Please fix/remove problematic XIDs and rerun macro.") 
    'Stop the macro because we can't continue until the xid problem has been sorted out 
    End 
End If 

再次，非常感谢蒂姆他非常有效的方法！