查找跟踪重复项的方法答案

【问题标题】：Find method to track duplicates查找跟踪重复项的方法
【发布时间】：2014-04-23 19:17:06
【问题描述】：

第一次发帖，希望能得到一些帮助。 :)

我有一组数据，我试图通过这些数据来计算只有在某些条件匹配时才会出现重复的次数，否则不应该计算在内。我编写了以下内容，它适用于较小的数据集，但是当我尝试使用较大的数据集时，Excel 冻结了。我的猜测是由于嵌套循环和 40k 条目。我意识到 Find 方法会更好地解决这个问题，但无法让它发挥作用。

Sub pileOn()

Dim i As Long
Dim j As Long
Dim k As Long

i = 1
j = 1
k = 0

Do
    Do
        If ((Worksheets("Data").Cells(i, 21).Value = _
             Worksheets("Data").Cells(j, 21).Value) And (i <> j)) Then
               If ((Worksheets("Data").Cells(j, 4).Value > _
                   Worksheets("Data").Cells(i, 4).Value) And _
                   (Worksheets("Data").Cells(j, 16).Value < _
                    Worksheets("Data").Cells(i, 16).Value)) Then

                  k = k + 1

               End If
        End If

        j = j + 1

    Loop Until IsEmpty(Worksheets("Data").Cells(j, 21))

    i = i + 1
    j = 1

Loop Until IsEmpty(Worksheets("Data").Cells(i, 21))

Worksheets("Results").Cells(1, 2).Value = k

End Sub

感谢任何帮助。

【问题讨论】：

如果您将整个范围读入一个变体数组并进行处理，而不是访问工作表来读取每个单元格，您的处理将会快得多。

标签： excel vba find nested-loops

【解决方案1】：

我通过使用脚本字典执行检查然后突出显示找到的任何行来解决这个问题：

Sub DupeChecker()
    ' setup the selection
    ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Select

    ' now check that row for dupes, and flag each dupe with some formatting
    Dim d As Object, e
    Set d = CreateObject("scripting.dictionary")
    For Each e In Intersect(Columns(ActiveCell.Column), ActiveSheet.UsedRange)
        If e.Value <> vbNullString Then
            If Not d.exists(e.Value) Then d(e.Value) = 1 Else _
                e.Font.ColorIndex = 4
        End If
    Next
End Sub

然后您可以测试突出显示以计算您的欺骗：

If ThisWorkbook.Sheets(1).Cells(1, "A").Font.ColorIndex = 4 then
    MsgBox("duplicate text in A1!")
End If

我不久前从 MrExcel 论坛中提取了这段代码，所以所有功劳归功于 mirabeau！

【讨论】：

这是一个很好的起点！我非常喜欢使用Collection-type 对象进行重复检查。话虽如此，我认为这个回复可能需要更多的充实——例如，最初的问题不仅是检查第 21 列中的欺骗，而且还要查看第 4 列和第 16 列中的值。
Ohh ok Dan... 你是对的 hehehe 所以要继续实现原始功能，你可以在 for 循环中添加更多技巧：'For Each e In Intersect(Columns(ActiveCell. Column), ActiveSheet.UsedRange) If e.Value vbNullString Then If Not d.exists(e.Value) Then d(e.Value) = 1 Else _ e.Font.ColorIndex = 4 If e.Value > d.值然后结束如果下一个'哦，伙计！我不知道评论降价是如此不同！我会带着另一个答案回来......

【解决方案2】：

根据 Tim 的建议，我整理了一个 pileOn2 脚本......在面对大量比较时，变体数组提供了极好的速度：

Option Explicit
Sub pileOn2()

Dim i As Long, j As Long, Dupes As Long, _
    LastRow As Long
Dim wsData As Worksheet
Dim rTemp As Range
Dim dCol() As Variant, pCol() As Variant, _
    uCol() As Variant

'set references up front
Set wsData = ThisWorkbook.Worksheets("Data")
With wsData
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
Set rTemp = Range(wsData.Cells(1, 4), wsData.Cells(LastRow, 4))
dCol = rTemp
Set rTemp = Range(wsData.Cells(1, 16), wsData.Cells(LastRow, 16))
pCol = rTemp
Set rTemp = Range(wsData.Cells(1, 21), wsData.Cells(LastRow, 21))
uCol = rTemp
i = 1
j = 1
Dupes = 0

'find occurrences where:
'(1) dupe value for i and j in column 21
'(2) value in j > i in column 4
'(3) value in j < i in column 16
For i = 1 To LastRow
    For j = 1 To LastRow
        If uCol(i, 1) = uCol(j, 1) And dCol(j, 1) > dCol(i, 1) And pCol(j, 1) < pCol(i, 1) Then
            Dupes = Dupes + 1
        End If
    Next j
Next i

'write duplicate count out
ThisWorkbook.Worksheets("Results").Cells(1, 2) = Dupes

End Sub

【讨论】：