Excelにて、ファイル内の複数シートの重複データーへ色を付けるVBAコードをご教授願います。

Excelにて、ファイル内の複数シートでの重複データーへ色を付けるVBAコードを
ご教授願います。

現在、１シート内の対応は何とかできるのですが、複数シートの場合のコードに苦慮
しております
※対象ファイルは、10ほどあり、それぞれシート数も1~５シートでまちまちす。

データーは、A列２行目から入力されています

End Sub
Sub Test() '色を付ける
Dim i As Long, j As Long
For i = 1 To 1000
For j = 1 To 1
If WorksheetFunction.CountIf(Range("A1:C1000"), Cells(i, j)) > 1 Then
Cells(i, j).Interior.ColorIndex = 6
End If
Next j
Next i
End Sub


お分かりになる方がおられましたらご教授願います。

質問者からの補足コメント

• Iいつも大変お世話になっております。
  
  今回確認したファイルは、シート４つあります。
  すみません。説明不足でした
  データーが10個ではなく今回処理をしたいファイル数が10ファイルあるという事で、
  データーは、常に200以上A2から下へ入力されています。
  For i = 1 To 10　⇒変更　For i = 1 To ３0０にして、
  実施してみた所、開いているシート(カソールがあるシート)のみが色が付き、他の３シート
  データーには、色がつきません、また、空セルにも色がついてしまいます。
  
  説明不足で、すみませんでした

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/08/31 23:05

• 対応して頂きありがとうございます
  
  説明がうまくできず誠にすみません
  下記内容がやりたかったことです。
  ※　そのシートに重複はなくても別シートに同じデータがある場合に色を付ける
  
  説明不足で、すみません

  No.2の回答に寄せられた補足コメントです。 補足日時：2020/09/01 16:07

• 早々のありがとうございます。
  説明不足でたびたびすみません
  A列2行目以降のセルには、データーがない空セルがあり、
  実行した所、空セルも色がついてしまう状況です。できれば
  空セルは対象外にすることはできないでしょうか
  
  忙しい中、対応して頂き感謝しております。

  No.3の回答に寄せられた補足コメントです。 補足日時：2020/09/01 18:49

No.4 ベストアンサー 回答者： tom04 回答日時： 2020/09/01 19:48

No.2・3です。

途中に空白セルがあるのですか？
それでは前回のコードの

「重複なしに登録」する部分の

＞For i = 1 To UBound(myR, 1)
の次の行に
＞If myR(i, 1) <> "" Then

＞Next i
の前に
＞End If

を追加してみてください。m(_ _)m

この回答へのお礼

ありがとうございました
思い通りに行きました。
貴重な時間を割いて対応して頂き感謝いたします。

本当にありがとうございました。

お礼日時：2020/09/01 21:24

No.3 回答者： tom04 回答日時： 2020/09/01 18:24

No.2です。

結局すべてのシートが対象になるわけですね。

各シートともA列2行目以降を対象としています。
標準モジュールにしてください。

Sub Sample2()
　Dim myDic As Object
　Dim i As Long, k As Long
　Dim lastRow As Long
　Dim myStr As String
　Dim myR

　　Set myDic = CreateObject("Scripting.Dictionary")
　　　'//▼各シートのA列データを重複なしに一旦登録//
　　　For k = 1 To Worksheets.Count
　　　　With Worksheets(k)
　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "A")) '//←各シートのA列2行目～最終行まで//
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　If Not myDic.exists(myR(i, 1)) Then
　　　　　　　　　myDic.Add myR(i, 1), 1
　　　　　　　　Else
　　　　　　　　　myDic(myR(i, 1)) = myDic(myR(i, 1)) + 1
　　　　　　　　End If
　　　　　　　Next i
　　　　End With
　　　Next k

　　　'//▼ココから操作//
　　　For k = 1 To Worksheets.Count
　　　　With Worksheets(k)
　　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myStr = .Cells(i, "A")
　　　　　　　If myDic(myStr) > 1 Then
　　　　　　　　.Cells(i, "A").Interior.ColorIndex = 6
　　　　　　　Else
　　　　　　　　.Cells(i, "A").Interior.ColorIndex = xlNone
　　　　　　　End If
　　　　　Next i
　　　　End With
　　　Next k
　　　　Set myDic = Nothing
　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

No.2 回答者： tom04 回答日時： 2020/09/01 11:04

こんにちは！

横からお邪魔します。
各シートごとのA列に重複データに重複するデータがあるセルに色を付けたい！というコトですかね。

一例です。

Sub Sample1()
　Dim i As Long, k As Long

　　For k = 1 To Worksheets.Count
　　　With Worksheets(k)
　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If WorksheetFunction.CountIf(.Range("A:A"), .Cells(i, "A")) > 1 Then
　　　　　　.Cells(i, "A").Interior.ColorIndex = 6
　　　　　Else
　　　　　　.Cells(i, "A").Interior.ColorIndex = xlNone
　　　　　End If
　　　　Next i
　　　End With
　　Next k
End Sub

こんな感じではどうでしょうか？

※　そのシートに重複はなくても別シートに同じデータがある場合に色を付ける！
という意味であれば当然コードも変わってきます。

的外れならごめんなさい。m(_ _)m

No.1 回答者： ママチャリ 回答日時： 2020/08/31 21:05

こんな感じ？

Sub Test()
Dim i As Long, j As Long
Dim ws As Worksheet
Dim c As Long
For i = 1 To 10
For j = 1 To 1
c = 0
For Each ws In Worksheets
c = c + WorksheetFunction.CountIf(ws.Cells, Cells(i, j))
Next ws
If c > 1 Then
Cells(i, j).Interior.ColorIndex = 6
End If
Next j
Next i
End Sub

この回答へのお礼

いつも早々に対応して頂きありがとうございます
引き続きよろしくお願いいたします。

お礼日時：2020/08/31 23:14