colA上的Excel VBA標記副本（在所有工作表上工作，包括活動頁）

Question

我想在工作簿中的所有Worksheet上標記重複項。如果副本存在於其他工作表上，則代碼標記下方僅重複。 如果它們存在於Activesheet上，我想標記它們。 （如果可以標記不同的顏色，如果重複僅存在於Activesheet中，則好得多）

下面是解決類似案例的鏈接，我需要解決的問題。 [鏈接]（https://stackoverflow.com/a/25252503/5493335）「循環顯示被激活的工作表中的列A的值，然後搜索所有剩餘工作表的列A，如果它找到該ID，則將單元格背景顏色設爲紅色。by Siddhart Rout「

我只對此代碼添加一項更改以消除空行上的顏色。 但這些代碼是標記（紅色）只有當重複是另一個工作表。 如果我在activeworksheet上發現重複，我想知道不同顏色的makr。

我會盡力去做自己，並改變其他條件，但它不起作用。任何人都可以幫我解決這個問題。

在此先感謝。

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 

Answer 1

我會跟你的代碼重構之後去：

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 

Answer 2

除去If ws.Name <> Sh.Name然後線和end if下方與之線。