Excel VBA跨工作簿​​高亮显示重复项

我试图突出显示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 '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 

Answer 1

这是一个简单的例子，应该给你一些想法，并指出你在正确的方向。 如果你有问题，请告诉我。

 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 

Answer 2

这段代码的function是循环显示被激活的工作表中的列A的值，然后search所有剩余工作表的列A，如果find该ID，则将单元格背景上色为红色。

尝试和testing

我已经评论了代码，所以你不应该有理解它的问题。 如果你仍然这样做，只需回发:)

尝试这个

 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