VBA ２つの列を比較し、重複するデータを削除

質問

以下の処理をScripting.Dictionaryを使って実現できるのであれば、そのコードをお教えください。

A列にデータが約4万個あります。
B列にもデータがあります。

A列とB列を比較し、A列にしかないデータをD列に転記、B列にしかないデータをE列に転記したい。

回答No.1

kkkkkm · ベストアンサー

Scripting.Dictionaryを使わなくてよろしければ

Sub Test()
Dim LastRowA As Long, LastRowB As Long

LastRowA = Cells(Rows.Count, "A").End(xlUp).Row
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row

Call Check(Range("A1:A" & LastRowA), Range("B1:B" & LastRowB), Range("C1"))
Call Check(Range("B1:B" & LastRowA), Range("A1:A" & LastRowB), Range("D1"))

End Sub

Sub Check(ByRef SRng As Range, ByRef AreaRng As Range, ByRef WRng As Range)
Dim S_Data As Variant
Dim W_Data() As Variant
Dim mIndex As Variant
Dim i As Long, j As Long

S_Data = SRng
j = 0
For i = 1 To UBound(S_Data)
mIndex = Application.Match(S_Data(i, 1), AreaRng, 0)
If IsError(mIndex) Then
ReDim Preserve W_Data(j)
W_Data(j) = S_Data(i, 1)
j = j + 1
End If
Next
WRng.Resize(UBound(W_Data) + 1, 1).Value = WorksheetFunction.Transpose(W_Data)

End Sub

お礼

回答ありがとうございます。 正しく動きました。

Powered by GRATICA

回答No.7

kkkkkm

おまけ
サブプロシージャを使わないパターン

Sub Test3()
Dim myDic1 As New Dictionary, myDic2 As New Dictionary
Dim S_Data As Variant
Dim tmp() As Variant, W_Data1() As Variant, W_Data2() As Variant
Dim i As Long, j As Long, k As Long
Dim LastRowA As Long, LastRowB As Long

LastRowA = Cells(Rows.Count, "A").End(xlUp).Row
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row

S_Data = Range("B1:B" & LastRowB).Value
For i = 1 To UBound(S_Data)
If Not myDic1.Exists(S_Data(i, 1)) Then
myDic1.Add S_Data(i, 1), "R"
End If
Next i

S_Data = Range("A1:A" & LastRowA).Value
j = 1
For i = 1 To UBound(S_Data)
If Not myDic2.Exists(S_Data(i, 1)) Then
myDic2.Add S_Data(i, 1), "W"
ReDim Preserve tmp(j)
tmp(j) = S_Data(i, 1)
j = j + 1
End If
Next i

For i = 1 To UBound(tmp)
If Not myDic1.Exists(tmp(i)) Then
myDic1.Add tmp(i), "W"
Else
myDic1.Remove tmp(i)
End If
Next i

j = 0: k = 0
For i = 0 To myDic1.Count - 1
If myDic1.Items(i) = "W" Then
ReDim Preserve W_Data1(j)
W_Data1(j) = myDic1.Keys(i)
j = j + 1
Else
ReDim Preserve W_Data2(k)
W_Data2(k) = myDic1.Keys(i)
k = k + 1
End If
Next i

Range("D1").Resize(UBound(W_Data1) + 1, 1).Value = WorksheetFunction.Transpose(W_Data1)
Range("E1").Resize(UBound(W_Data2) + 1, 1).Value = WorksheetFunction.Transpose(W_Data2)

Set myDic2 = Nothing
Set myDic1 = Nothing

End Sub

お礼

何度も回答ありがとうございます。 いくつか提案いただいた中で、処理時間に差があれば、一番速いものを使っていきたいと思います。

Powered by GRATICA

回答No.6

kkkkkm

回答No.5の訂正です。

何度もすみません。合間合間にやるので細かいところに気が付かないことが多々あったりします。

S_Data = SRng
For i = 1 To UBound(S_Data)
If Not myDic.Exists(S_Data(i, 1)) Then
myDic.Add S_Data(i, 1), "W"
End If
Next i

j = 0
For i = 0 To myDic.Count - 1
If myDic.Items(i) = "W" Then
ReDim Preserve W_Data(j)
W_Data(j) = myDic.Keys(i)
j = j + 1
End If
Next i

は以下に変更するとループが減ります

S_Data = SRng
j = 0
For i = 1 To UBound(S_Data)
If Not myDic.Exists(S_Data(i, 1)) Then
myDic.Add S_Data(i, 1), "W"
ReDim Preserve W_Data(j)
W_Data(j) = S_Data(i, 1)
j = j + 1
End If
Next i

お礼

回答ありがとうございます。

Powered by GRATICA

回答No.5

kkkkkm

Application.Matchを使わずにScripting.Dictionaryだけを使ってA列B列それぞれ各列の中での重複も削除する場合には以下で。

ツール→参照設定で
Microsoft Scripting Runtime
を参照設定して下さい。

Sub Test2()
Dim LastRowA As Long, LastRowB As Long

LastRowA = Cells(Rows.Count, "A").End(xlUp).Row
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row

Call Dic_Check(Range("A1:A" & LastRowA), Range("B1:B" & LastRowB), Range("D1"))
Call Dic_Check(Range("B1:B" & LastRowB), Range("A1:A" & LastRowA), Range("E1"))

End Sub

Sub Dic_Check(ByRef SRng As Range, ByRef AreaRng As Range, ByRef WRng As Range)
Dim myDic As New Dictionary
Dim S_Data As Variant
Dim W_Data() As Variant
Dim i As Long, j As Long

S_Data = AreaRng
For i = 1 To UBound(S_Data)
If Not myDic.Exists(S_Data(i, 1)) Then
myDic.Add S_Data(i, 1), "R"
End If
Next i

S_Data = SRng
For i = 1 To UBound(S_Data)
If Not myDic.Exists(S_Data(i, 1)) Then
myDic.Add S_Data(i, 1), "W"
End If
Next i

j = 0
For i = 0 To myDic.Count - 1
If myDic.Items(i) = "W" Then
ReDim Preserve W_Data(j)
W_Data(j) = myDic.Keys(i)
j = j + 1
End If
Next i

WRng.Resize(UBound(W_Data) + 1, 1).Value = WorksheetFunction.Transpose(W_Data)

Set myDic = Nothing
End Sub

お礼

何度も回答ありがとうございます。 いくつか提案いただいた中で、処理時間に差があれば、一番速いものを使っていきたいと思います。

Powered by GRATICA

回答No.4

kkkkkm

もう一個訂正です。

コピペした時に直し忘れてました

Call Check(Range("B1:B" & LastRowA), Range("A1:A" & LastRowB), Range("E1"))

を

Call Check(Range("B1:B" & LastRowB), Range("A1:A" & LastRowA), Range("E1"))

お礼

回答ありがとうございます。

Powered by GRATICA

回答No.3

kkkkkm

> A列にしかないデータをD列に転記、B列にしかないデータをE列に転記したい。

すみません回答No.1,回答No.2ともに

A列にしかないデータをC列に転記
B列にしかないデータをD列に転記

にしてました

回答No.1
Call Check(Range("A1:A" & LastRowA), Range("B1:B" & LastRowB), Range("D1"))
Call Check(Range("B1:B" & LastRowA), Range("A1:A" & LastRowB), Range("E1"))

に

回答No.2
F1に
=IF(COUNTIF(B$1:B1,A1)<1,ROW(),"")
G1に
=IF(COUNTIF(A$1:A1,B1)<1,ROW(),"")
D1に
=IFERROR(INDEX(A:A,SMALL(F:F,ROW(A1))),"")
E1に
=IFERROR(INDEX(B:B,SMALL(G:G,ROW(A1))),"")

に

それぞれ変更してください。

お礼

回答ありがとうございます。

Powered by GRATICA

回答No.2

kkkkkm

関数でよろしければ

E1に
=IF(COUNTIF(B$1:B1,A1)<1,ROW(),"")
F1に
=IF(COUNTIF(A$1:A1,B1)<1,ROW(),"")
C1に
=IFERROR(INDEX(A:A,SMALL(E:E,ROW(A1))),"")
D1に
=IFERROR(INDEX(B:B,SMALL(F:F,ROW(A1))),"")

として必要なだけ下にコピー

お礼

回答ありがとうございます。

Powered by GRATICA