Excel 2007 マクロ 同列のデータの重複チェック

質問

Excel 2007 マクロ　同列のデータの重複チェック

A列で重複しているデータをチェックします。
重複しているデータについて、B列にフラグをつけます。
フラグはどの行とどの行が重複しているのかわかるようにしたいです。
そのため重複している行同士ごとにフラグをつけます。

上記の内容はマクロで実現できるのでしょうか。

元データと完成形の画像を添付します。

よろしくお願いします。

回答No.4

myRange · ベストアンサー

データを１回だけ読む方法で一案。

見出し（Ａ１，Ｂ１）
データ（Ａ２～～）
マクロ実行前に結果Ｂ列のクリアー不要。

'----------------------------------------
Sub Test()
　Dim myDic
　Dim Cnt As Long
　Dim Rng As Range
　Dim myRange As Range

　Set myRange = Range("A2", Cells(Rows.Count, "A").End(xlUp))
　myRange.Offset(0, 1).ClearContents

　Set myDic = CreateObject("Scripting.Dictionary")

For Each Rng In myRange
　If myDic.Exists(Rng.Value) = False Then
　　　If WorksheetFunction.CountIf(myRange, Rng) > 1 Then
　　　　　Cnt = Cnt + 1
　　　　　myDic.Add Rng.Value, Cnt
　　　　　Rng.Offset(0, 1).Value = Cnt
　　　End If
　Else
　　　Rng.Offset(0, 1).Value = myDic.Item(Rng.Value)
　End If
Next Rng

End Sub
'----------------------------------------------

以上です。

お礼

ご回答ありがとうございました。参考にさせて頂きます。シンプルな内容で助かります。

回答No.3

KURUMITO

Ａ１セルに型番とありＡ2セル以降にデータがあるとしたらＢ2セルには次の式を入力して下方にオートフィルドラッグすればよいでしょう。マクロで処理することもないように思いますが。

=IF(A2="","",IF(COUNTIF(A:A,A2)>1,IF(COUNTIF(A$1:A1,A2)>0,INDEX(B$1:B1,MATCH(A2,A$1:A1,0)),MAX(B$1:B1)+1),""))

お礼

ご回答ありがとうございました。参考にさせて頂きます。

回答No.2

mitarashi

バリエーションを二つ追加させていただきます。
なお、B列は事前に空にしておく必要があります。

'連想配列を用いる方法
Sub test2()
Dim targetRange As Range, myCell As Range
Dim myDic As Object
Dim myKeys As Variant
Dim strKey As String
Dim i As Long, j As Long

Set myDic = CreateObject("Scripting.Dictionary")
With ActiveSheet
Set targetRange = .Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp))
End With
For Each myCell In targetRange.Cells
strKey = myCell.Value
If Not myDic.exists(strKey) Then
myDic.Add strKey, myCell
Else
Set myDic(strKey) = Union(myDic(strKey), myCell)
End If
Next
myKeys = myDic.keys
j = 1
For i = 0 To myDic.Count - 1
If myDic(myKeys(i)).Cells.Count > 1 Then
myDic(myKeys(i)).Offset(0, 1).Value = j
j = j + 1
End If
Next i
Set myDic = Nothing
End Sub

'オーソドックスな方法、但し高速化の為配列に入れて処理してみました
'あまり検証してないので、バグがあったら悪しからず
Sub test3()
Dim targetRange As Range
Dim i As Long, j As Long, k As Long
Dim buf As Variant
Dim hitFlag As Boolean

With ActiveSheet
Set targetRange = .Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp).Offset(0, 1))
End With
buf = targetRange
k = 1
For i = 1 To UBound(buf, 1)
hitFlag = False
If IsEmpty(buf(i, 2)) Then
For j = i + 1 To UBound(buf, 1)
If buf(i, 1) = buf(j, 1) Then
buf(i, 2) = k: buf(j, 2) = k
hitFlag = True
End If
Next j
End If
If hitFlag Then k = k + 1
Next i
targetRange = buf
End Sub

お礼

ご回答ありがとうございました。参考にさせて頂きます。

回答No.1

tom04

こんばんは！
A列の2行目以降にデータがありB列に表示させるとします。
無理やりって感じになります。

一例ですが・・・

Sub test()
Dim i, j As Long
j = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To j
If WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(j, 1)), Cells(i, 1)) > 1 _
And WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(i, 1)), Cells(i, 1)) = 1 Then
Cells(i, 2) = WorksheetFunction.Count(Range(Cells(2, 2), Cells(i, 2))) + 1
End If
Next i
Dim k, L As Long
L = Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To L
If WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(L, 1)), Cells(k, 1)) > 1 Then
Cells(k, 2) = WorksheetFunction. _
VLookup(Cells(k, 1), Range(Cells(2, 1), Cells(L, 2)), 2, False)
End If
Next k
End Sub

2段階でやってみました。
重複数が2以上で初回に出てくるデータ行に1からの連番をB列に表示させ、
その結果を元にもう一度B列に重複数が2個以上の物は
VLOOKUPで既出数値を表示するようにしてみました。

以上、参考になればよいのですが
他に良い方法があればごめんなさいね。m(__)m

お礼

ご回答ありがとうございました。参考にさせて頂きます。