大数据集的唯一计数公式

我无法确定在邻近单元格中input1或0的方式，以指示处理大型数据集时值是否是唯一的。 我已经阅读了多种方法来完成这一点，但是没有一个看起来对我的目的是有效的：我正在使用Excel 2010的实例（所以我没有数据透视表中的区别计数function，当我尝试使用PowerPivot时，它崩溃我的文件由于处理限制。

在这个StackOverflow的问题： 简单的数据透视表来计算唯一的值有build议使用SUMPRODUCT或COUNTIF ，但是当我使用50,000+行时，这会导致可怕的性能和约35 MB而不是〜3 MB的文件大小。 我想知道，无论是公式还是VBA，是否有更好的解决scheme。

我想完成的一个例子是（ Unique列是相邻的单元格）：

 Name Week Unique John 1 1 Sally 1 1 John 1 0 Sally 2 1 

我试图编写与COUNTIF相同的function，但没有成功：

 For Each Cell In ThisWorkbook.Worksheets("Overtime & Type Data").Range("Z2:Z" & DataLastRow) If Worksheets("Overtime & Type Data").Cells(Cell.Row, 26) <> Worksheets("Overtime & Type Data").Cells(Cell.Row - 1, 26) Then FirstCell = Cell.Row End If If (Worksheets("Overtime & Type Data").Range(Cells(FirstCell, 26), Cells(Cell.Row, 26)) = Worksheets("Overtime & Type Data").Range(Cells(Cell.Row, 26))) = True Then Cell.Value = 1 Else Cell.Value = 0 End If Next Cell 

Answer 1

该代码在不到3秒的时间内成功运行了超过130,000行。 调整列字母以适合您的数据集。

 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 

Answer 2

一种方法是按名称和周sorting。 然后，您可以通过与前一行比较来确定任何行的唯一。

如果您需要保存订单，您可以先写一个索引编号列（1,2,3 …）来跟踪订单。 计算Unique后，按索引sorting以恢复原始顺序。

整个过程可以用相对较less的步骤手动完成，或者用VBA自动完成。

Answer 3

我不确定这个值能够达到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 

Answer 4

几乎任何批量操作都会打败涉及工作表单元格的循环。 您可以通过执行内存中的所有计算来修剪时间，只有在完成时才将值返回到工作表。

 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 

以前的经验告诉我，各种数据（以及硬件等）将影响到过程的时间安排，但是在我随机采样数据中，我收到了这些过去的时间。

50Klogging….. 0.53秒
130Klogging…. 1.32秒
500Klogging…. 4.92秒