colA上的Excel VBA标记重复（处理所有工作表包括activesheet）

我想在工作簿中的所有工作表上标记“重复”。在代码标记下方，只有在其他工作表上存在重复项时，才进行复制。 如果它们存在于Activesheet上，我还想标记它们。 （如果仅在Activesheet中存在副本，则可以在不同的颜色上进行标记，效果会更好）

这里有一个类似案例的解决方案链接，我需要解决的问题。[a链接]（）“在激活的工作表中循环a列的值，然后搜索所有剩余工作表的a列，如果找到ID，则将单元格背景颜色改为红色。by Siddhart Rout”

我只对此代码添加了一个更改，以消除空行上的颜色。 但这些代码只有在重复的工作表是另一个工作表时才被标记（红色）。 如果我在活动工作表上发现了重复的颜色，我想知道如何在不同的颜色上进行标记

我会试着做自己和改变与其他条件，但它不工作。谁能帮我解决那个问题

提前谢谢

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
                if strSearch <> "" then 'eliminated color empty cell

                '~~> 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
                   End if 
            Next i
        End With
    End Sub

Private子工作簿\u SheetActivate（ByVal Sh作为对象）
朦胧如长，wsLRow如长，我如长
Dim aCell As系列
将ws设置为工作表
作为字符串的Dim stresearch
与Sh
“~~>获取工作表A列的最后一行
“~~>哪个被激活了
lRow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
“~~>从列中删除现有颜色
“~~>这是为了满足
“~~>其他纸张，以便单元格可以重新着色
.Columns（1）.Interior.ColorIndex=xlNone
“~~>循环通过工作表的单元格，该单元格
“~~>被激活了
对于i=1至lRow
“~~>将ID存储在变量中
strSearch=.Range（“A”&i）.Value
如果strSearch“”则“”消除了颜色空单元格
“~~>循环浏览工作簿中的工作表
对于此工作簿中的每个ws。工作表
“~~>这是为了确保它不会
“~~>搜索本身
如果ws.Name Sh.Name那么
“~~>获取工作表A列的最后一行
wsLRow=ws.Range（“A”&ws.Rows.Count）.End（xlUp）.Row
“~~>使用。查找以快速检查副本
设置aCell=ws.Range（“A1:A”&wsLRow）.Find（What:=strearch_
LookIn:=xlValues_
看：=xlother_
搜索顺序：=xlByRows_
SearchDirection:=xlNext_
MatchCase:=假_
SearchFormat:=False）
“~~>如果找到，则将单元格涂成红色并退出循环
“~~>搜索其余的工作表没有意义
如果不是的话，亚塞尔什么都不是
Sh.Range（“A”和i）.Interior.ColorIndex=3
退出
如果结束
如果结束
下一个ws
如果结束
接下来我
以
端接头

删除

如果ws.Name Sh.Name

那么行，如果

下面的
与它对齐，那么结束。
我将对代码进行以下重构：

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Dim IDsRng As Range, IDCell As Range
    Dim ws As Worksheet
    Dim strSearch As String
    Dim foundInOtherSheet As Boolean, foundInActiveSheet As Boolean

    With Sh
        Set IDsRng = .Range("A1", .Cells(.Rows.count, 1).End(xlUp)) '<--| set the IDs range as all column A not empty cells with some "text" content
        '~~> 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
    End With


    For Each IDCell In IDsRng '<--| Loop through ID cells (i.e. column A "text" cells of the activated sheet)
        '~~> Store the ID in a variable
        strSearch = IDCell.Value

        foundInActiveSheet = WorksheetFunction.CountIf(IDsRng, strSearch) > 1 '<--| count possible dupes in active sheet
        foundInOtherSheet = False '<--| initialize it at every new ID

        '~~> 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
                With ws
                    foundInOtherSheet = WorksheetFunction.CountIf(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)), strSearch) > 1
                    If foundInOtherSheet Then Exit For '~~> If found then color then no point searching rest of the sheets
                End With
            End If
        Next

        Select Case True '<--| now act accordingly to where duplicates have been found
            Case foundInOtherSheet And Not foundInActiveSheet '<--| if duplicates found in "other" sheets only
                IDCell.Interior.ColorIndex = 3 '<--| red
            Case foundInOtherSheet And foundInActiveSheet '<--| if duplicates found in "other" sheets and in "active" one too
                IDCell.Interior.ColorIndex = 6 '<--| yellow
            Case Not foundInOtherSheet And foundInActiveSheet '<--| if duplicates found in "active" sheets only
                IDCell.Interior.ColorIndex = 14 '<--| green
        End Select

    Next
End Sub

Private子工作簿\u SheetActivate（ByVal Sh作为对象）
Dim IDsRng作为范围，IDCell作为范围
将ws设置为工作表
作为字符串的Dim stresearch
将foundInOtherSheet设置为布尔值，将FoundInotiveSheet设置为布尔值
与Sh
设置IDsRng=.Range（“A1”，.Cells（.Rows.count，1）.End（xlUp）），这是为了适应其他工作表中的任何删除，以便可以对单元格重新着色
.Columns（1）.Interior.ColorIndex=xlNone
以
对于IDsRng“1”中的每个IDCell
如果在其他工作表中找到，则退出“~~>，如果找到，则使用颜色，则无需搜索其他工作表
以
如果结束
下一个
选择Case True“删除
如果ws.Name Sh.Name
那么行，如果下面与它对齐，则结束。它不起作用Nathan。在我试图改变许多条件之前，我就写了这篇文章。删除这些行后，代码标记为红色everyValue不仅重复。。。内森不像看上去那么容易。谢谢你对这些问题的关注。你好。感谢您回复用户3598756。它在你的计算机上工作，因为我有错误？一个重要的信息是我需要比较数字而不是文本。但对于测试，我尝试使用文本，但在foundInActiveSheet=WorksheetFunction.CountIf（IDsRng，strSearch）>1[/code]行中，我仍然有一个eroor 1004调试，这一行[code]不受欢迎。如果我的答案解决了您的问题，请单击答案旁边的复选标记将其从灰色变为已填写，将其标记为已接受。非常感谢。user3598756-我写过你的代码不工作。*我需要检查数字是否重复。**我将代码放入工作簿中。编辑以关闭所有的
Specialcells（）
，以便ID可以是您需要的任何值