如果您是 a) 按小时计酬但觉得薪水过低，b) 计划在例行处理期间小睡，或 c) a) 和 b) 两者，请忽略此提交。
对于任何接近 800K 行（30 列）的数据集，您都会想要进入变体数组领域。由于处理工作表值所需的时间通常为 5-7%，因此非常适合大型数据块。
每当“重复”一词出现时，我都会立即开始思考Scripting.Dictionary 对象在其Keys 上的唯一索引如何受益。在这个解决方案中，我使用了一对字典来识别具有重复 Circle Score 值的数据行。
2400 万个数据单元需要存储和传输。批量方法每次都击败单个方法，剥离数据的最大方法是将所有 800K 行 × 30 列填充到一个变体数组中。所有处理都在内存中，结果返回到报告工作表en masse。
isolateDuplicateCircleScores代码
Sub isolateDuplicateCircleScores()
Dim d As Long, v As Long, csc As Long, stmp As String
Dim ky As Variant, itm As Variant, vVALs As Variant, dCSs As Object, dDUPs As Object
Dim w As Long, vWSs As Variant
'early binding
'dim dCSs As new scripting.dictionary, dDUPs As new scripting.dictionary
appTGGL bTGGL:=False
'late binding - not necessary with Early Binding (see footnote ¹)
Set dCSs = CreateObject("Scripting.Dictionary")
Set dDUPs = CreateObject("Scripting.Dictionary")
'set to the defaults (not necessary)
dCSs.comparemode = vbBinaryCompare
dDUPs.comparemode = vbBinaryCompare
'for testing on multiple row number scenarios
'vWSs = Array("CircleScores_8K", "CircleScores_80K", "CircleScores_800K")
'for runtime
vWSs = Array("CircleScores") '<~~ your source worksheet here
For w = LBound(vWSs) To UBound(vWSs)
'ThisWorkbook.Save
Debug.Print vWSs(w)
Debug.Print Timer
With Worksheets(vWSs(w))
On Error Resume Next
Worksheets(vWSs(w) & "_dupes").Delete
On Error GoTo 0
ReDim vVALs(0)
dCSs.RemoveAll
dDUPs.RemoveAll
'prep a new worksheet to receive the duplicates
.Cells(1, 1).CurrentRegion.Resize(2).Copy
With Worksheets.Add(after:=Worksheets(.Index))
.Name = vWSs(w) & "_dupes"
With .Cells(1, 1)
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone
.Value = .Value2
.Offset(1, 0).EntireRow.ClearContents
End With
End With
'finish prep with freeze row 1 and zoom to 80%
With Application.Windows(1)
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
.Zoom = 80
End With
'grab all of the data into a variant array
ReDim vVALs(0)
csc = Application.Match("CircleScore", .Rows(1), 0) 'CircleScore column number needed later
vVALs = .Range(.Cells(2, 1), _
.Cells(.Cells(Rows.Count, csc).End(xlUp).Row, _
.Cells(1, Columns.Count).End(xlToLeft).Column)).Value2
'Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1) '1:~800K
'Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2) '1:~30
End With 'done with the original worksheet
'populate the dDUPs dictionary using the key index in dCSs
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
If dCSs.exists(vVALs(v, csc)) Then
stmp = vVALs(v, 1)
For d = LBound(vVALs, 2) + 1 To UBound(vVALs, 2)
stmp = Join(Array(stmp, vVALs(v, d)), ChrW(8203))
Next d
dDUPs.Add Key:=v, Item:=stmp
If Not dDUPs.exists(dCSs.Item(vVALs(v, csc))) Then
stmp = vVALs(dCSs.Item(vVALs(v, csc)), 1)
For d = LBound(vVALs, 2) + 1 To UBound(vVALs, 2)
stmp = Join(Array(stmp, vVALs(dCSs.Item(vVALs(v, csc)), d)), ChrW(8203))
Next d
dDUPs.Add Key:=dCSs.Item(vVALs(v, csc)), Item:=stmp
End If
Else
dCSs.Item(vVALs(v, csc)) = v
End If
Next v
'split the dDUPs dictionary items back into a variant array
d = 1
ReDim vVALs(1 To dDUPs.Count, 1 To UBound(vVALs, 2))
For Each ky In dDUPs.keys
itm = Split(dDUPs.Item(ky), ChrW(8203))
For v = LBound(itm) To UBound(itm)
vVALs(d, v + 1) = itm(v)
Next v
d = d + 1
Next ky
'put the values into the duplicates worksheet
With Worksheets(vWSs(w) & "_dupes")
.Cells(2, 1).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
.Rows(1).Copy
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
End With
.Cells.Sort Key1:=.Columns(csc), Order1:=xlAscending, _
Key2:=.Columns(1), Order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
End With
Debug.Print Timer
Next w
dCSs.RemoveAll: Set dCSs = Nothing
dDUPs.RemoveAll: Set dDUPs = Nothing
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
Sample Data and Results
800K 行 × 30 列随机样本数据
~123K 行 × 30 列重复行（排序和格式化大约需要一分半钟）
Timed Results
tbh，我从来没有在旧笔记本电脑上安装 32 位版本的 Excel，在不重新启动 Excel 的情况下多次运行 800K 通行证。重新启动后，结果与显示的一致。 64 位 Excel 反复运行，没有任何问题。
大型工作表附录
在处理包含大数据块的工作表时，有一些一般性的改进可以限制您的等待时间。您将 Excel 用作中型数据库工具，因此请将数据工作表视为应有的原始数据。
- 如果您使用的不是 64 位版本的 Excel，那么您所做的一切都是在浪费时间。见What version of Office am I using? 和Choose the 32-bit or 64-bit version of Office。
- 另存为 Excel 二进制工作簿（例如 .XLSB）。文件大小通常为原始文件的 25-35%。加载时间得到改善，一些计算更快（抱歉，后者没有经验定时数据）。一些会导致 .XLSX 或 .XLSM 崩溃的操作可以在 .XLSB 上正常运行。
- 在工作簿的选项中禁用自动保存/自动恢复。 （[alt]+F、T、S、[alt]+D、[OK]）。当您尝试做某事时，没有什么比等待自动保存完成更令人恼火的了。当你想要保存时，习惯Ctrl+S。
- 不惜一切代价避免易变函数¹；特别是在整个数据范围内使用的公式中。 COUNTIF 公式中的单个
TODAY() 填充行的范围会让您经常坐在拇指上。
- 说到公式，尽可能将所有公式恢复为其结果值。
- 合并单元格、条件格式、数据验证以及使用格式和样式使单元格看起来漂亮会减慢您的速度。尽量减少使用任何带走原始数据的东西。并不像任何人实际上会查看 80 万行数据。
- 删除数据后，在空白单元格上使用主页 ► 编辑 ► 清除 ► 全部清除。点击 Del 只会清除内容，可能不会重置
Worksheet.UsedRange property; Clear All 将有助于在下次保存时重置 .Used Range。
- 如果您的计算机使用了一种或多种 Excel [无响应] 方案，请重新启动计算机。 Excel 永远不会从这些问题中完全恢复，并且简单地重新启动 Excel 以重新开始会更慢，并且以后更有可能进入相同的无响应条件。
¹ 如果您可以将 Scripting.Dictionary 的后期绑定转换为早期绑定，则必须将 Microsoft Scripting Runtime 添加到 VBE 的工具 ► 参考中。
² 当整个工作簿中的任何内容发生变化时，可变函数都会重新计算，而不仅仅是在影响其结果的某些内容发生变化时。 volatile 函数的示例有 INDIRECT、OFFSET、TODAY、NOW、RAND 和 RANDBETWEEN。 CELL 和 INFO 工作表函数的一些子函数也会使它们变得易变。