大型数据集的唯一计数公式

这段代码在不到3秒内成功运行了130000多行。调整列字母以适合数据集。

Sub tgr()

    Const colName As String = "A"
    Const colWeek As String = "B"
    Const colOutput As String = "C"

    Dim ws As Worksheet
    Dim rngData As Range
    Dim DataCell As Range
    Dim rngFound As Range
    Dim collUniques As Collection
    Dim arrResults() As Long
    Dim ResultIndex As Long
    Dim UnqCount As Long

    Set ws = ThisWorkbook.Sheets("Overtime & Type Data")
    Set rngData = ws.Range(colName & 2, ws.Cells(Rows.Count, colName).End(xlUp))
    Set collUniques = New Collection
    ReDim arrResults(1 To rngData.Cells.Count, 1 To 1)

    On Error Resume Next
    For Each DataCell In rngData.Cells
        ResultIndex = ResultIndex + 1
        collUniques.Add ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value, ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value
        If collUniques.Count > UnqCount Then
            UnqCount = collUniques.Count
            arrResults(ResultIndex, 1) = 1
        Else
            arrResults(ResultIndex, 1) = 0
        End If
    Next DataCell
    On Error GoTo 0

    ws.Cells(rngData.Row, colOutput).Resize(rngData.Cells.Count).Value = arrResults

End Sub

一种方法是按名称和星期排序。然后,您可以通过与前一行进行比较来确定任何行的唯一性。

如果您需要保持顺序,可以首先编写一列索引号(1、2、3、…)来跟踪顺序。计算“唯一”后,按索引排序以恢复原始顺序。

整个过程可以用相对较少的步骤手动完成,也可以用VBA自动完成。

我不确定这对50000个值的效果如何,但它在大约一秒钟内就可以达到1500个。

Sub unique()
    Dim myColl As New Collection
    Dim isDup As Boolean
    Dim myValue As String
    Dim r As Long

    On Error GoTo DuplicateValue
    For r = 1 To Sheet1.UsedRange.Rows.Count
        isDup = False
        'Combine the value of the 2 cells together
        ' and add that string to our collection
        'If it is already in the collection it errors
        myValue = Sheet1.Cells(r, 1).Value & Sheet1.Cells(r, 2).Value
        myColl.Add r, myValue
        If isDup Then
            Sheet1.Cells(r, 3).Value = "0"
        Else
            Sheet1.Cells(r, 3).Value = "1"
        End If
    Next
    On Error GoTo 0
    Exit Sub
DuplicateValue:
    'The value is already in the collection so put a 0
    isDup = True
    Resume Next
End Sub

几乎任何批量操作都会击败涉及工作表单元格的循环。通过在内存中执行所有计算并只将值返回到工作表,您可能可以稍微缩短时间 全体 当它完成时。

Sub is_a_dupe()
    Dim v As Long, vTMP As Variant, vUNQs As Variant, dUNQs As Object

    Debug.Print Timer
    On Error GoTo bm_Uh_Oh
    Set dUNQs = CreateObject("Scripting.Dictionary")

    With Worksheets("Sheet1")

        vTMP = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)).Value2
        ReDim vUNQs(1 To UBound(vTMP, 1), 1 To 1)

        For v = LBound(vTMP, 1) To UBound(vTMP, 1)
            If dUNQs.Exists(Join(Array(vTMP(v, 1), vTMP(v, 2)))) Then
                vUNQs(v, 1) = 0
            Else
                dUNQs.Add Key:=Join(Array(vTMP(v, 1), vTMP(v, 2))), _
                          Item:=vTMP(v, 2)
                vUNQs(v, 1) = 1
            End If
        Next v

        .Cells(2, 3).Resize(UBound(vUNQs, 1), 1) = vUNQs

    End With

    Debug.Print Timer

bm_Uh_Oh:
    dUNQs.RemoveAll
    Set dUNQs = Nothing
End Sub

以前的经验告诉我,各种数据(以及硬件等)会影响过程的计时,但在我的随机样本数据中,我收到了这些经过的时间。

50K记录…..0.53秒
130K条记录……1.32秒
500K条记录……4.92秒