複数のシートをループして複数のループを繰り返す方法

Question

列内の重複をすべて見つけることができるように、VBAコードを作成しようとしています。それらを赤で強調表示し、メッセージボックスを表示します複製されたものをすべて列挙します。

と、複数のシートに渡ってC列に対してこれを行うコードにしたいと思います。これは、本質的に条件付き書式を置き換えることです。ブックが約8秒遅くなっていたためです。

これは私がこれまで行ってきたことですが、実際には機能していません。

Sub FindDuplicates() 

    Sheetcounter = 0 
    Set MyData = Worksheets("Sheet1").Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row) 

    Do Until Sheetcounter = 3 
    Set MyUniqueList = CreateObject("Scripting.Dictionary") 
    MyUniqueList.RemoveAll 

    Range(Cells(1, 1), Cells(5000, 1)).Interior.Color = xlNone 

    Application.ScreenUpdating = False 

    MyDupList = "": MyCounter = 0 

    For Each Cell In MyData 
      If Evaluate("COUNTIF(" & MyData.Address & "," & Cell.Address & ")") > 1 Then 
       If Cell.Value <> "" Then 
        Cell.Interior.Color = RGB(255, 80, 80) 
         If MyUniqueList.exists(CStr(Cell)) = False Then 
          MyCounter = MyCounter + 1 
          MyUniqueList.Add CStr(Cell), MyCounter 
           If MyDupList = "" Then 
            MyDupList = Cell 
           Else 
            MyDupList = MyDupList & vbNewLine & Cell 
           End If 
         End If 
       End If 
      Else 
        Cell.Interior.ColorIndex = xlNone 
      End If 
    Next Cell 

    Application.ScreenUpdating = True 

    If MyDupList <> "" Then 
     MsgBox "The following entries have been used more than once:" & vbNewLine & MyDupList 
     Else 
     MsgBox "There were no duplicates found in " & MyData.Address 
    End If 
    Sheetcounter = Sheetcounter + 1 
    If Sheetcounter = 1 Then 
    Set MyData = Worksheets("Sheet2").Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row) 
    End If 
    If Sheetcounter = 2 Then 
    Set MyData = Worksheets("Sheet3").Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row) 
    End If 

    Loop 

End Sub 

Answer 1

次のようにあなたは、あなたのサブを簡素化することができます：

Option Explicit 

Sub FindDuplicates() 
    Dim sheetCounter As Long 
    Dim myData As Range, cell As Range 
    Dim myUniqueList As Scripting.Dictionary 

    Set myUniqueList = CreateObject("Scripting.Dictionary") 
    For sheetCounter = 1 To 3 
     myUniqueList.RemoveAll 
     With Worksheets("Sheet00" & sheetCounter) 
      Set myData = .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 
     End With 
     myData.Interior.Color = xlNone 

     For Each cell In myData.SpecialCells(xlCellTypeConstants) 
      If WorksheetFunction.CountIf(myData, cell) > 1 Then 
       cell.Interior.Color = RGB(255, 80, 80) 
       If Not myUniqueList.Exists(CStr(cell)) Then myUniqueList.Add CStr(cell), myUniqueList.Count + 1 
      End If 
     Next cell 

     If myUniqueList.Count > 0 Then 
      MsgBox "The following entries have been used more than once:" & vbNewLine & Join(myUniqueList.Keys, vbNewLine) 
     Else 
      MsgBox "There were no duplicates found in " & myData.Address 
     End If 
    Next sheetCounter 
End Sub