循环一个macros的重复

我有一个macros运行通过数据寻找重复的条码，然后移动'最古老的'重复（基于另一列的date）到另一个表。

这里的问题是，我有多个重复由于数据录入错误，需要至less运行macros3次。 我想这个程序自动运行，所以我需要循环这个macros，直到没有重复。 我正在考虑“尽pipe”，但会欣赏一些指导。 这里是代码：

Sub DupMove() 'Moves the oldest duplicate to seperate sheet Dim t As Single Dim d As Object, x&, xcol As String Dim lc&, lr&, k(), e As Range xcol = "C" lc = Cells.Find("*", after:=[a1], SearchDirection:=xlPrevious).Column lr = Cells.Find("*", after:=[a1], SearchDirection:=xlPrevious).Row ReDim k(1 To lr, 1 To 1) Set d = CreateObject("scripting.dictionary") For Each e In Cells(1, xcol).Resize(lr) If Not d.exists(e.Value) Then d.Add e.Value, Array(Cells(e.Row, 5), e.Row) k(e.Row, 1) = 1 Else If d(e.Value)(0).Value < Cells(e.Row, 5).Value Then k(d(e.Value)(1), 1) = "" k(e.Row, 1) = 1 d(e.Value)(0) = Cells(e.Row, 5) d(e.Value)(1) = e.Row End If End If Next e Cells(1, lc + 1).Resize(lr) = k Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1 x = Cells(1, lc + 1).End(4).Row Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1") Cells(x + 1, 1).Resize(lr - x, lc).Clear Cells(1, lc + 1).Resize(x).Clear End Sub 

Answer 1

这里有一个粗略的方法来查找重复。 适应您的需求。 你可以把它放在一个工作表更改事件（我不build议），但这确实find所有的愚蠢

 Private Sub this() Dim rng As Range Dim rCell As Range Dim this As String Dim arr(9) Set rng = ThisWorkbook.Sheets("Sheet1").Range("a1:a10") For Each rCell In rng.Cells this = rCell.Value For x = LBound(arr, 1) To UBound(arr, 1) If this = arr(x) Then rCell.Interior.ColorIndex = 7 Exit For ElseIf this <> arr(x) And arr(x) = vbNullString Then arr(x) = this Exit For End If Next x Next rCell End Sub