使用腳本字典找到使用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 

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