arrays - Excel 宏数组

Question

目前，我有一个宏可以遍历列表并删除重复值(在一列中)，但事实证明它效率非常低。对于检查重复项的每个条目，它必须遍历整个列；我的文件目前有 50,000 个条目，这不是一个小任务。

我认为宏工作的一种更简单的方法是让宏检查该值是否在数组中。如果是，则删除该条目所在的行。如果不是，则将该值添加到数组中。

有人可以提供一些关于宏的基本轮廓的帮助吗？谢谢

Answer 1

下面的代码将循环遍历源数据并将其存储在数组中，同时检查重复项。收集完成后，它使用数组作为键来知道要删除哪些列。

由于删除后潜在的屏幕更新数量较多，请务必关闭屏幕更新。 (包含)

Sub Example()
    Application.ScreenUpdating = false
    Dim i As Long
    Dim k As Long
    Dim StorageArray() As String
    Dim iLastRow As Long
    iLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    ReDim StorageArray(1 To iLastRow, 0 To 1)

    'loop through column from row 1 to the last row
    For i = 1 To iLastRow
        'add each sheet value to the first column of the array
        StorageArray(i, 0) = ActiveSheet.Range("A" & i).Value
        '- keep the second column as 0 by default
        StorageArray(i, 1) = 0
        '- as each item is added, loop through previously added items to see if its a duplicate
        For k = 1 To i-1
            If StorageArray(k, 0) = StorageArray(i, 0) Then
                'if it is a duplicate set the second column of the srray to 1
                StorageArray(i, 1) = 1
                Exit For
            End If
        Next k
    Next i

    'loop through sheet backwords and delete rows that were maked for deletion
    For i = iLastRow To 1 Step -1
        If StorageArray(i, 1) = 1 Then
            ActiveSheet.Range("A" & i).EntireRow.Delete
        End If
    Next i

    Application.ScreenUpdating = true
End Sub

---

根据要求，这里有一个类似的方法，使用集合而不是数组进行键索引:(RBarryYoung)

Public Sub RemovecolumnDuplicates()
    Dim prev as Boolean
    prev = Application.ScreenUpdating
    Application.ScreenUpdating = false
    Dim i As Long, k As Long

    Dim v as Variant, sv as String
    Dim cl as Range, ws As Worksheet
    Set ws = ActiveWorksheet    'NOTE: This really should be a parameter ...

    Dim StorageArray As New Collection
    Dim iLastRow As Long
    iLastRow = ws.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    'loop through column from row 1 to the last row
    i = 1
    For k = 1 To iLastRow
        'add each sheet value to the collection
        Set cl = ws.Cells(i, 1)
        v = cl.Value
        sv = Cstr(v)

        On Error Resume Next
            StorageArray.Add v, sv
        If Err.Number <> 0 Then
            'must be a duplicate, remove it
            cl.EntireRow.Delete
            'Note: our index doesn't change here, since all of the rows moved
        Else
            'not a duplicate, so go to the next row
            i = i + 1
        End If
    Next k

    Application.ScreenUpdating = prev
End Sub

请注意，此方法不需要对列中单元格的值假定任何数据类型或整数限制。

(Mea Culpa:我必须在记事本中手动输入此内容，因为我的 Excel 现在正忙于运行项目测试。因此可能存在一些拼写/语法错误...)