突出显示工作簿中的重复项 [英] Highlight duplicates across a workbook
本文介绍了突出显示工作簿中的重复项的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!
问题描述
我试图突出显示12张工作簿中的重复项.
I am trying to highlight duplicates across a workbook of 12 sheets.
我们跟踪ID#,如果其他任何工作表上都有ID#(值),我想突出显示该单元格.
We track ID#s and I want to highlight the cell if an ID# (value) is on any of the other sheets.
当我在本工作簿"中使用以下代码时,它适用于一个工作表,而不适用于多个工作表.
When I use the below code in the "This Workbook" it applies within a sheet, and not across the multiple sheets.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Rng As Range
Dim cel As Range
Dim col As Range
Dim c As Range
Dim firstAddress As String
'Duplicates will be highlighted in red
Target.Interior.ColorIndex = xlNone
For Each col In Target.Columns
Set Rng = Range(Cells(1, col.Column), Cells(Rows.Count, col.Column).End(xlUp))
Debug.Print Rng.Address
For Each cel In col
If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
Set c = Rng.Find(What:=cel.Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.ColorIndex = 3
Set c = Rng.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End If
Next
Next col
推荐答案
下面是一个简化的示例,该示例应为您提供一些想法并指明正确的方向. 如果您有任何疑问,请告诉我.
Here is a simplified example that should give you some ideas and point you in the right direction. If you have an questions, let me know.
Sub collected_ids_example()
' enable microsoft scripting runtime --> tools - references
' For convenience I put all code in 2 subs/functions
' This code assumes you want every cell with a duplicate id highlighted.
' Although it is easy enough to modify that if you want.
Dim sh As Worksheet
Dim id_to_addresses As New Dictionary
Dim id_ As Range
' For every worksheet collect all ids and their associated adressses
' for the specified range.
For Each sh In ThisWorkbook.Sheets
For Each id_ In sh.Range("A4:A100")
If Not IsEmpty(id_) Then
If Not id_to_addresses.Exists(id_.Value) Then
Set id_to_addresses(id_.Value) = New Collection
End If
id_to_addresses(id_.Value).Add get_full_address(id_)
End If
Next id_
Next sh
' Color each cell with a duplicate id
Dim collected_id As Variant
Dim adresses As Collection
Dim c As Range
For Each collected_id In id_to_addresses
Dim duplicate_address As Variant
Set adresses = id_to_addresses(collected_id)
'You have a duplicate if an id is associated with more than 1 addrress
If adresses.Count >= 2 Then
For Each duplicate_address In adresses
Set c = Range(duplicate_address)
c.Interior.ColorIndex = 3
Next duplicate_address
End If
Next collected_id
End Sub
Private Function get_full_address(c As Range) As String
get_full_address = "'" & c.Parent.Name & "'!" & c.Address(External:=False)
End Function
这篇关于突出显示工作簿中的重复项的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!
查看全文