Excel VBA突出显示工作簿中的重复 [英] Excel VBA to Highlight Duplicates across a workbook

问题描述

我正在尝试通过12张工作簿突出显示重复的内容。本质上我们正在使用它来跟踪ID＃，如果ID＃（值）已经列在任何其他工作表上，我想突出显示单元格。我能够提出下面的代码，但即使我在这个工作簿中使用它，它只适用于一个工作表，而不是跨多个工作表。

谢谢！

  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 
 
 
 
'重复将以红色突出显示
 Target.Interior.ColorIndex = xlNone 
对于每个col在Target.Columns 
设置Rng =范围（单元格（1，col.Column），单元格（Rows.Count ，col.Column）.End（xlUp））
 Debug.Print Rng.Address 
 
对于每个cel在col 
如果WorksheetFunction.CountIf（Rng，cel.Value）> ; 1然后
设置c = Rng.Find（什么：= cel.Value，LookIn：= xlValues）
如果不是c不是然后
 firstAddress = c.Address 
 Do 
 c.Interior.ColorIndex = 3 
设置c = Rng.FindNext（c）
循环，而不是c不是，而c.Address<> firstAddress 
 End If 
 End If 
 Next 
 Next col 
  

解决方案

这是一个简化的例子，应该给你一些想法，并指出你在正确的方向。
如果您有任何问题，请通知我。

  Sub collect_ids_example（）
'启用微软脚本运行时 - >工具 - 引用
'为方便起见，我将所有代码放在2个子程序/函数中
'此代码假定您希望每个单元格都重复显示。 
'虽然很容易修改，如果你想要的。 
 
 Dim sh As Worksheet 
 Dim id_to_addresses As New Dictionary 
 Dim id_ As Range 
 
'对于每个工作表收集所有ids及其相关联的地址
'指定范围。 
对于每个sh在ThisWorkbook.Sheets 
对于每个id_在sh.Range（A4：A100）
如果不是IsEmpty（id_）然后
如果不是id_to_addresses.Exists（ id_.Value）然后
设置id_to_addresses（id_.Value）=新集合
结束If 
 id_to_addresses（id_.Value）.Add get_full_address（id_）
 End If 
下一个id_ 
下一个sh 
 
'为每个单元格重复一次的颜色
 Dim gather_id作为Variant 
 Dim地址作为集合
 Dim c As Range 
每个collect_id在id_to_addresses 
 Dim duplicate_address As Variant 
设置地址= id_to_addresses（gather_id）
 
'如果一个id与多于1个addrress相关联，您有一个重复
如果adresses.Count> = 2然后
对于每个duplicate_address在地址
设置c =范围（duplicate_address）
 c.Interior.ColorIndex = 3 
下一个duplicate_address 
结束如果
下一个collect_id 
 End Sub 
 
私有函数get_full_address（c As Range）As String 
 get_full_address ='& c.Parent.Name& ！ &安培; c.Address（External：= False）
结束函数
  

I am trying to highlight duplicates across a workbook of 12 sheets. Essentially we are using it to track ID#s and I want to highlight the cell if this ID#(value) has already been listed on any of the other sheets. I was able to come up with the below code, but even when I use in the "This Workbook" it only applies it within a sheet, and not across the multiple sheets.

Thanks!

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

这篇关于Excel VBA突出显示工作簿中的重复的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！