Question

第一次发帖并希望得到一些帮助。：）

我有一组我试图通过的数据，只有在某些条件匹配时才计算重复的次数，否则不应计算。我编写了以下内容，它可以处理较小的数据集，但是当我尝试使用更大的数据集时，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

感谢任何帮助。

Answer 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！

Answer 2

我根据蒂姆的建议汇总了一个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

查找跟踪重复项的方法

2 个答案: