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 

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

（过失：我不得不在记事本中手工输入这一点，因为我的Excel是忙碌的运行项目的测试，现在所以可能有一些拼写/语法错误...。）

Answer 2

我会建议填充你的列，然后使用公式来找到重复项并删除它们。我没有为你的实际代码（你没有给我们任何代码）

dim a as range 
dim b as range 
set a = Range ("A1") 

Do while Not isEmpty(A) 
Set b = a.offset(1,0) 

If b = a then 
b= "" 
else a.offset (1,0) 

Loop 

我相信你可以把过滤器中的代码，或只是你的rember运行宏之前fillter。

Answer 3

这是一个后续对我的评论。 循环50k记录 + 循环阵列将是一个这样一个简单的操作过度杀死。

就像我在我的评论中提到的，将数组中的值复制到新工作表中。然后在50k条目旁边插入空白列并执行Vlookup或CountIf。完成后，执行一次自动筛选，然后删除重复条目。我们来举个例子，看看它是如何工作的。

假设我们有一个包含1000个项目的数组？在1页中我们有50k数据。下面的代码将与1000 items in Array和50k Data见快照

此代码的模块在粘贴进行测试（的代码了不到5秒以完成）

Sub Sample() 
    Dim ws As Worksheet, wstemp As Worksheet 
    Dim LRow As Long 
    Dim Ar(1 To 1000) As Long 
    Dim startTime As String, EndTime As String 

    startTime = Format(Now, "hh:mm:ss") 

    Set ws = Sheets("Sheet1") 
    Set wstemp = Sheets.Add 

    '~~> Creating a dummy array 
    For i = 1 To 1000 
     Ar(i) = i 
    Next i 

    '~~> Copy it to the new sheet 
    wstemp.Range("A1:A1000").Value = Application.Transpose(Ar) 

    With ws 
     LRow = .Range("A" & .Rows.Count).End(xlUp).Row 

     .Columns(2).Insert Shift:=xlToRight 
     .Range("B1").Value = "For Deletion" 
     .Range("B2:B" & LRow).FormulaR1C1 = "=COUNTIF(" & wstemp.Name & "!C[-1],RC[-1])" 
     .Columns(2).Value = .Columns(2).Value 

     '~~> Remove any filters 
     .AutoFilterMode = False 

     '~~> Filter, offset(to exclude headers) and delete visible rows 
     With .Range("B1:B" & LRow) 
      .AutoFilter Field:=1, Criteria1:="<>0" 
      .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
     End With 

     '~~> Remove any filters 
     .AutoFilterMode = False 

     .Columns(2).Delete 
    End With 

    EndTime = Format(Now, "hh:mm:ss") 

    MsgBox "The process started at " & startTime & " and finished at" & EndTime 
End Sub 

Answer 4

对于Excel 2007及更高版本：将数组复制到工作表并使用removeduplicates方法：

set ws = worksheets.add 
ws.[A1].resize(ubound(yourarray,1),ubound(yourarray,2)).value = yourarray 
ws.usedrange.removeduplicates columns:=1, header:=no 

这里假定数组的下限为1，表示要删除的列是列1，并且列表中没有标题。然后可以找到新范围的边界并将其读回到阵列中（首先擦除当前阵列）。