Question

我有一个宏来运行查找重复条形码的数据，然后将“最早的”副本（基于另一列中的日期）移动到另一个工作表。

问题在于，由于数据输入错误，我有多个重复项，需要运行宏至少3次。我希望这个程序自动运行，所以我需要循环这个宏，直到没有重复。我在想'Do While'，但会很感激一些指导。这是代码：

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

这是查找重复项的粗略方法。根据您的需求进行调整你可以将它放在工作表更改事件中（我不推荐），但这确实找到了所有的dupes

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

循环重复的宏

1 个答案: