ダブリ数字の有無の確認にのマクロについて

質問

恐れ入ります、エクセルのマクロで質問があります。
ダブリ数字の有無の確認にのマクロについてです。
下記のように数字の羅列が有ります。
上の番号から順番に検索して列の中にダブった数字（２つ以上）が無いかを確認するマクロはどのように作成すればいいでしょうか？
下記の場合、238075と238220が２以上つあるので、そこが緑色になるようにしたいです。
宜しくお願い致します。

238075
238096
238220
92528
237702
92378
237662
238077
238063
238065
238208
92523
238205
238253
237702
238220
237708
238075

回答No.2

ka_na_de · ベストアンサー

一例です。

Sub test03()
　　Dim myRange As Range
　　Dim c As Range

　　Set myRange = Range("A1", Cells(Rows.Count, "A").End(xlUp))

　　For Each c In myRange
　　　　If Application.WorksheetFunction.CountIf(myRange, c.Value) > 1 Then
　　　　　　c.Interior.ColorIndex = 10
　　　　End If
　　Next c

　　Set myRange = Nothing
End Sub

お礼

ありがとうございます！
これこそが欲しかったマクロでした。
本当になんでこんなにマクロが素早く正確にかけるのか！？羨ましくて仕方ないです。
きっと仕事がバリバリものすごくできる方なのでしょうね。

回答No.3

ka_na_de

＃２です。
おそらく、前回の質問の続きですよね。
http://oshiete1.goo.ne.jp/qa5798289.html

改めて、２パターン作ってみました。

test04: ＃２のコードを素直に組み込むんだものです。
　　　　理解しやすい反面、２度ループを回すので無駄です。
test05: 前回の質問の処理の中で、だぶりを判定し色づけします。

Sub test05()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange1 As Range
　　Dim myRange2 As Range
　　Dim myUnionRange As Range
　　Dim c1 As Range
　　Dim c2 As Range
　　Dim myCt As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp))
　　Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp))

　　For Each c1 In myRange1
　　　　myCt = 0
　　　　Set myUnionRange = Nothing
　　　　For Each c2 In myRange2
　　　　　　If c2.Value = c1.Value Then
　　　　　　　　If c2.Offset(, 1).Value = "" Then
　　　　　　　　　　c1.Offset(, 1).Interior.ColorIndex = 3
　　　　　　　　Else
　　　　　　　　　　c1.Offset(, 1).Value = c2.Offset(, 1).Value
　　　　　　　　End If
　　　　　　　　If myUnionRange Is Nothing Then
　　　　　　　　　　Set myUnionRange = c2
　　　　　　　　Else
　　　　　　　　　　Set myUnionRange = Union(c2, myUnionRange)
　　　　　　　　End If
　　　　　　　　myCt = myCt + 1
　　　　　　End If
　　　　Next c2
　　　　If myCt > 1 Then
　　　　　　c1.Offset(, 1).Interior.ColorIndex = 10
　　　　　　myUnionRange.Interior.ColorIndex = 10
　　　　End If
　　Next c1

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
　　Set myUnionRange = Nothing
End Sub

'---------------------------------------------------------

Sub test04()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange1 As Range
　　Dim myRange2 As Range
　　Dim c1 As Range
　　Dim c2 As Range
　　Dim myCt As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp))
　　Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp))

　　For Each c1 In myRange1
　　　　myCt = 0
　　　　For Each c2 In myRange2
　　　　　　If c2.Value = c1.Value Then
　　　　　　　　If c2.Offset(, 1).Value = "" Then
　　　　　　　　　　c1.Offset(, 1).Interior.ColorIndex = 3
　　　　　　　　Else
　　　　　　　　　　c1.Offset(, 1).Value = c2.Offset(, 1).Value
　　　　　　　　End If
　　　　　　　　myCt = myCt + 1
　　　　　　End If
　　　　Next c2
　　　　If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10
　　Next c1

　　For Each c2 In myRange2
　　　　If Application.WorksheetFunction.CountIf(myRange2, c2.Value) > 1 Then
　　　　　　c2.Interior.ColorIndex = 10
　　　　End If
　　Next c2

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
End Sub

回答No.1

tom04

こんばんは！
VBAでないので、参考にならなかったら無視してください。
単純に条件付書式を使った方法です。

↓の画像のようにA列にデータが入っているとします。
当方使用のExcel2003の場合ですが、
A列全てを範囲指定し、条件付書式の「数式が」を選択し
数式欄に
=COUNTIF(A:A,A1)>1
として緑を選択しています。

以上、的外れなら読み流してくださいね。m(__)m