【VBA】特定の範囲で同じ値を含むセルの色を変える

Excelのマクロに関して質問です。
特定の範囲(複数行と複数列)内で重複した値（セル内の最初の4文字が同じもの）を含むセルの色を変えたいです。
さらに、重複した値ごとに色分けをしたいです。例えば重複した値[1111]と重複した値[1112]の時では、前者が赤色で後者は青色、更に他の重複する値はまた別の色でというように、
要は、どのセルとセルが重複しているか色分けをして一目瞭然にしたいです。

※なお特定の範囲は以下の変数を利用します。
dataRow = Workbooks(booksName).Worksheets(sheetsName).Range("A2").End(xlDown).Row 'データの入っている最終行を取得
dataColum = Workbooks(booksName).Worksheets(sheetsName).Range("A1").End(xlToRight).Column 'データの入っている最終列を取得

どなたか知恵をお貸し下さい。よろしくお願いします。.

No.2 ベストアンサー 回答者： tom04 回答日時： 2013/05/12 17:05

No.1です！

補足とお礼欄の件について・・・

前回のコードに手を加えるだけで大丈夫だと思いますが、
ココとココ！を手直し！というと判らなくなると思いますので、
もう一度最初からコードを載せてみます。

Sub 重複色付け2()
Dim i As Long, endRow As Long, cnt As Long, c As Range, r As Range, myArea As Range
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set myArea = wS1.Cells(1, 1).CurrentRegion
Application.ScreenUpdating = False
With wS2
For Each c In myArea
If c <> "" Then
cnt = cnt + 1
.Cells(cnt, 2) = Left(c, 4)
End If
Next c
endRow = .Cells(Rows.Count, 2).End(xlUp).Row
With Range(wS2.Cells(1, 3), wS2.Cells(endRow, 3))
.Formula = "=COUNTIF(B:B,B1)"
.Value = .Value
End With
For i = endRow To 1 Step -1
If WorksheetFunction.CountIf(.Range("B:B"), .Cells(i, 2)) > 1 Or .Cells(i, 3) = 1 Then
.Cells(i, 2).Resize(1, 2).Delete shift:=xlUp
End If
Next i
For Each c In myArea
Set r = wS2.Range("B:B").Find(what:=Left(c, 4), LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then
c.Interior.Color = r.Offset(, -1).Interior.Color
End If
Next c
End With
myArea.SpecialCells(xlCellTypeBlanks).Interior.Color = xlNone
Application.ScreenUpdating = True
End Sub

今度はご希望通りの表示になれば良いのですが・・・m(_ _)m

この回答への補足

ありがとうございます。早速試させて頂きましたが、
With Range(wS2.Cells(1, 3), wS2.Cells(endRow, 3))
のところで、
1004 アプリケーション定義またはオブジェクト定義のエラーです。
となってしまいます。
お手数お掛けします。。

補足日時：2013/05/12 22:17

この回答へのお礼

wS2を指定すれば動作しました！
本当に素晴らしいです！願っていた通りの動作になりました！
知識が豊富なことはもちろんですが、紳士的な対応にも感嘆します！
本当にありがとうございました！また是非、よろしくお願いします！！

お礼日時：2013/05/12 22:52

No.1 回答者： tom04 回答日時： 2013/05/11 21:48

こんばんは！

＞dataRow = Workbooks(booksName).Worksheets(sheetsName).Range("A2").End(xlDown).Row
と
＞dataColum = Workbooks(booksName).Worksheets(sheetsName).Range("A1").End(xlToRight).Column
は同一Bookの同一Sheetだと思いますので、単に「Sheet1」だというコトにしています。

↓の画像で右側がSheet2で作業用のSheetとします。
Sheet2のA列に重複データを塗りつぶしたい色を並べておきます。
この下準備ができた上での一例です。
標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub 重複色付け()
Dim i As Long, cnt As Long, c As Range, r As Range, myArea As Range
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set myArea = wS1.Cells(1, 1).CurrentRegion
Application.ScreenUpdating = False
With wS2
For Each c In myArea
cnt = cnt + 1
.Cells(cnt, 3) = Left(c, 4)
Next c
cnt = 0
For i = 1 To .Cells(Rows.Count, 3).End(xlUp).Row
Set r = .Range("B:B").Find(what:=.Cells(i, 3), LookIn:=xlValues, lookat:=xlWhole)
If WorksheetFunction.CountIf(.Range("C:C"), .Cells(i, 3)) > 1 And r Is Nothing Then
cnt = cnt + 1
.Cells(cnt, 2) = .Cells(i, 3)
End If
Next i
For Each c In myArea
Set r = wS2.Range("B:B").Find(what:=Left(c, 4), LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then
c.Interior.Color = r.Offset(, -1).Interior.Color
End If
Next c
.Range("B:C").Delete
End With
Application.ScreenUpdating = True
End Sub

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

この回答への補足

お礼に続いて更に追加のお願いです。
空白のセルは今回の処理(色分け)の対象外として処理することはできませんでしょうか？
何度も申し訳ないです。
よろしくお願いします。

補足日時：2013/05/12 00:10

この回答へのお礼

ありがとうございます！素晴らしいです！
本当に完璧に実現できました！感謝申し上げます！！

で、便乗してもう２点、以下の処理を追加してもらいたいです。
「Sheet2のB列にA列の色分けごとに利用した4桁の番号」と
「Sheet2のC列にA列の色分けごとのセルの数」
を表示したいです。

何卒、よろしくお願い申し上げます！！

お礼日時：2013/05/12 00:04