我有一些代码正在查找重复项并突出显示单元格:
Private Sub cmdDups_Click()
Dim Rng As Range
Dim cel As Range
Set Rng = ThisWorkbook.Worksheets("data").Range(Range("C1"), ThisWorkbook.Worksheets("data").Range("C" & Rows.Count).End(xlUp))
For Each cel In Rng
If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
cel.Interior.ColorIndex = 3
End If
Next cel
End Sub
但是,它令人困惑,因为它只是突出显示了所有内容。我将如何为它们添加一个子修复,例如 MASTER 和 CHILD。法师依据什么时候第一个找到,而子则为后事。
那可能吗?
最佳答案
我会避免过于频繁地调用工作表。它通常更喜欢通过内存工作。以下内容可能看起来相当广泛,但我尝试写一些评论以使其清楚:
Sub Test()
Dim lr As Long, x As Long, arr As Variant
Dim rng1 As Range, rng2 As Range
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("data")
'Find last used row in column C and prepare array to read through memory
lr = .Cells(.Rows.Count, 3).End(xlUp).Row
Set rng1 = .Range("C1:C" & lr)
arr = rng1.Value
'Loop over array and create a range object through Union and check against dictionary
For x = LBound(arr) To UBound(arr)
If WorksheetFunction.CountIf(rng, arr(x, 1)) > 1 Then
If Not rng2 Is Nothing Then
Set rng2 = Union(rng2, .Cells(x, 3))
Else
Set rng2 = .Cells(x, 3)
End If
If dict.exists(arr(x, 1)) Then
arr(x, 1) = "CHILD " & arr(x, 1)
Else
dict(arr(x, 1)) = 1
arr(x, 1) = "MASTER " & arr(x, 1)
End If
End If
Next
'Read back array and change cells colors
rng2.Interior.ColorIndex = 3
rng1.Value = arr
End With
End Sub
前:
后:
关于excel - 查找重复项和重命名主/子,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/61317917/