跨工作簿突出显示重复项

Question

我试图在一个包含12个工作表的工作簿中突出显示重复项。

我们跟踪ID号码，如果任何另一个工作表中有相同的ID号码（数值），我想突出显示该单元格。

当我在"This Workbook"中使用以下代码时，它只应用于一个工作表而不是多个工作表。

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

- cryocaustik

---

你应该能够使用 For Each Worksheet In ActiveWorkbook.Worksheets 循环遍历每个工作表，并将代码应用于每个工作表。 - dosdel

所有工作表中的ID是否都在同一列中？ - Siddharth Rout

是的，每个工作表中的ID号都在"A"列中。 - cryocaustik

发布了一个答案。请查看。 - Siddharth Rout

你可能需要刷新页面，因为我正在尝试代码并进行了一些编辑。 - Siddharth Rout

Siddharth Rout，你对你的VBA代码问题有什么建议吗？ - cryocaustik

Answer 1

这段代码的作用是循环遍历被激活的工作表中A列的值，然后搜索所有其它工作表中的A列，如果找到ID，则将单元格背景颜色标记为红色。

经过尝试和测试，我已经注释了这段代码，您应该可以轻松理解。如果您仍有问题，请随时发布回复 :)

请尝试此代码。

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Dim lRow As Long, wsLRow As Long, i As Long
    Dim aCell As Range
    Dim ws As Worksheet
    Dim strSearch As String

    With Sh
        '~~> Get last row in Col A of the sheet
        '~~> which got activated
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Remove existing Color from the column
        '~~> This is to cater for any deletions in the
        '~~> other sheets so that cells can be re-colored
        .Columns(1).Interior.ColorIndex = xlNone

        '~~> Loop through the cells of the sheet which
        '~~> got activated
        For i = 1 To lRow
            '~~> Store the ID in a variable
            strSearch = .Range("A" & i).Value

            '~~> loop through the worksheets in the workbook
            For Each ws In ThisWorkbook.Worksheets
                '~~> This is to ensure that it doesn't
                '~~> search itself
                If ws.Name <> Sh.Name Then
                    '~~> Get last row in Col A of the sheet
                    wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

                    '~~> Use .Find to quick check for the duplicate
                    Set aCell = ws.Range("A1:A" & wsLRow).Find(What:=strSearch, _
                                                               LookIn:=xlValues, _
                                                               LookAt:=xlWhole, _
                                                               SearchOrder:=xlByRows, _
                                                               SearchDirection:=xlNext, _
                                                               MatchCase:=False, _
                                                               SearchFormat:=False)

                    '~~> If found then color the cell red and exit the loop
                    '~~> No point searching rest of the sheets
                    If Not aCell Is Nothing Then
                        Sh.Range("A" & i).Interior.ColorIndex = 3
                        Exit For
                    End If
                End If
            Next ws
        Next i
    End With
End Sub

- Siddharth Rout

---

嗨Siddharth，感谢你的帮助。这个几乎达到了预期效果，但还有一些我想改变的地方：#1：我现在改为使用sheet_selectionchange（不确定为什么一开始没有使用它）， #2：我还需要它检查同一工作表上的重复项（似乎无法与当前代码一起工作）。 - cryocaustik

此外，似乎如果您有类似的数字组合（即123456＆654321），它会将它们两个都突出显示为重复项... - cryocaustik

Answer 2

这是一个简化的示例，应该能给你一些想法并指导你朝着正确的方向前进。 如果你有任何问题，请让我知道。

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

- Frank

---

你好，Frank。我对VBA非常陌生，请问你能否调整一下这段代码，使其在每个工作表上都可以突出显示A4:A100单元格范围？ - cryocaustik

我已按照您的要求更改了代码。如果您还有任何问题，请告诉我。 - Frank