エクセル２つの列にある値の完全一致を抜き出すVBA

Question

お世話になります。

エクセルでデータを貼り付けしたときに、
A列とB列の完全一致データを行ごと（AからMまで）別のシートに摘出したいと思っております。
また一致したデータは削除せずに全て摘出したいと考えております。

膨大なデータ数ですので処理に時間はかかると思っておりますが、
VBAで自動で処理できる方法をご教示頂けないでしょうか。

ご指導を宜しくお願いいたします。

tatsumaru77 · Accepted Answer

No11,12です。
下記URLにマクロをアップしました。
こちらからマクロを入手してください。
https://ideone.com/14Kmqj

tatsumaru77 · Answer

No14様
ご指摘、ありがとうございました。
Order1 はOrder2の誤りでした。
A列とB列が共に等しいものを抽出するので、ソートの対象となります。

質問者様へ
下記URLに修正版をアップしました。
https://ideone.com/VCavZE
No13でアップしたマクロは破棄してください。

高木さんWIN · Answer

Ａ列でって事なので、

key2:=sh3.Range("B1"), Order1:=xlAscending,

Ｂ列についてはいらないのでは？
名前付き引数：Order1 が key1 と同じなのも気にはなるけど。
初心者レベルなので見てみただけの感じであり無知ではありますが。

tatsumaru77 · Answer

No11です。
＞データをペーストしてみたのですが、
＞何も変わらず、摘出が行われていない状態でしたので、
＞マクロの実行を行ったところ、

はい。ペーストした後に、登録したマクロ「重複データ抽出」を実行します。

＞コンパイル エラーです。:
＞名前付き引数は、すでに指定されています。

コピペに誤りがあったとしか、考えられません。

Option Explicit
Public Sub 重複データ抽出()
～
End Sub

の範囲を正しくコピペしているか、確認してください。

又、
    sh3.Range("A1:M" & maxrow1 - 1).Sort key1:=sh3.Range("A1"), Order1:=xlAscending, key2:=sh3.Range("B1"), Order1:=xlAscending, Header:=xlNo
は、1行の文です。１行に収まっているか確認してください。

tatsumaru77 · Answer

Macがないので、Macで検証していません。
Sheet1から重複データを抽出し、Sheet2に格納します。
作業用のシートとして、シート名：作業用
を使用します。作業用シートを作成しておいてください。
Scripting.dictionaryを使用しないので、たぶん動作すると思います。
実行時間は当方の環境で、２万件で約４秒でした。
標準モジュールに登録してください。

Option Explicit
Public Sub 重複データ抽出()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim maxrow1 As Long
    Dim row3 As Long
    Dim row31 As Long
    Dim row2 As Long
    Dim key As String
    Dim old_key As String
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    Set sh3 = Worksheets("作業用")
    sh2.Cells.ClearContents
    sh3.Cells.ClearContents
    maxrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    sh2.Cells(1, 1).Resize(1, 13).Value = sh1.Cells(1, 1).Resize(1, 13).Value
    sh3.Cells(1, 1).Resize(maxrow1 - 1, 13) = sh1.Cells(2, 1).Resize(maxrow1 - 1, 13).Value
    sh3.Range("A1:M" & maxrow1 - 1).Sort key1:=sh3.Range("A1"), Order1:=xlAscending, key2:=sh3.Range("B1"), Order1:=xlAscending, Header:=xlNo
    old_key = ""
    row2 = 2
    For row3 = 1 To maxrow1 - 1
        key = sh3.Cells(row3, 1).Value & "|" & sh3.Cells(row3, 2).Value
        If key = old_key Then
            If row31 <> 0 Then
                sh2.Cells(row2, 1).Resize(1, 13).Value = sh3.Cells(row31, 1).Resize(1, 13).Value
                row31 = 0
                row2 = row2 + 1
            End If
            sh2.Cells(row2, 1).Resize(1, 13).Value = sh3.Cells(row3, 1).Resize(1, 13).Value
            row2 = row2 + 1
        Else
            row31 = row3
        End If
        old_key = key
    Next
    MsgBox ("完了")
End Sub

Qchan1962 · Answer

一応
処理時間は分かりません・・未検証

Sub Example02()
Application.ScreenUpdating = False
ActiveSheet.Copy
Dim arData As Variant
Dim i As Long
Dim v()
Dim Rng As Range
arData = Range(Cells(1, "A"), Cells(Rows.Count, "M").End(xlUp)).Value
ReDim v(1 To UBound(arData))
For i = 1 To UBound(arData)
    v(i) = arData(i, 1) & arData(i, 2)
Next
Cells(1, "N").Resize(UBound(v)) = WorksheetFunction.Transpose(v)
For i = 1 To UBound(v)
    If Application.CountIf(Range(Cells(1, "N"), Cells(Rows.Count, "N").End(xlUp)), v(i)) <= 1 Then
        If Rng Is Nothing Then
            Set Rng = Cells(i, 1)
        Else
            Set Rng = Union(Rng, Cells(i, 1))
        End If
    End If
Next
Rng.EntireRow.Delete
Columns("N:N").Delete
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

Qchan1962 · Answer

#8です
Macエクセルですか・・・
残念です
CreateObject("Scripting.dictionary")が使えません
StrCompも使えるか分かりません
一応、　https://qiita.com/r_keir/items/6f03a753bbd32dc8cce7
で対策し添削する必要があるようです

ローカル環境にMacエクセルが無い為、代替え手法が上手くいくか、
処理速度などの確認も出来ない為、これ以上の回答は出来そうもありません

Qchan1962 · Answer

こんばんは
出力の位置関係はどうします？ソートしますか（元データ順）・・
それとも2つ目が出てきた順で良いですか・・
ソートする　例見出しは考慮していません　新規ブックで操作されます
処理速度はデモデータが無いので未確認

Sub Example01()
ActiveSheet.Copy
Dim dic As Object
Set dic = CreateObject("Scripting.dictionary")
Dim arData As Variant
Dim ary()
Dim i As Long, j As Long
Dim v As String
Dim Rng As Range
arData = Range(Cells(1, "A"), Cells(Rows.Count, "M").End(xlUp)).Value
For i = 1 To UBound(arData)
    v = arData(i, 1) & arData(i, 2)
    If Not dic.Exists(v) Then
        dic.Add v, 0
    Else
        If dic.Item(v) = 0 Then
            ReDim Preserve ary(j)
            ary(j) = v
            j = j + 1
        End If
        dic.Item(v) = dic.Item(v) + 1
    End If
Next
Set dic = Nothing
Dim k, dupData()
Dim n As Long, x As Long
For j = 0 To UBound(ary)
    For i = 1 To UBound(arData)
        v = arData(i, 1) & arData(i, 2)
        If StrComp(v, ary(j)) = 0 Then
            For x = 1 To UBound(arData, 2)
                ReDim Preserve dupData(UBound(arData, 2), n)
                dupData(0, n) = i
                dupData(x, n) = arData(i, x)
            Next
            n = n + 1
        End If
    Next i
Next
Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(UBound(dupData, 2) + 1, UBound(dupData, 1) + 1).Value = WorksheetFunction.Transpose(dupData)
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns(1).Delete
End Sub

tatsumaru77 · Answer

補足要求です。
①見出しは1行目で、データは２行目からでしょうか。
②シート１のシート名は何でしょうか。(Sheet1で良いですか）
③シート２のシート名は何でしょうか。(Sheet2で良いですか）

fujillin · Answer

No5です。

10000行でテストしたけれど、1秒もかからないですよ。
（マシンの性能も影響すると思いますが・・・）

エクセル ２つの列にある値の完全一致を抜き出すVBA

No11,12です。

No14様

Ａ列でって事なので、

No11です。

Macがないので、Macで検証していません。

一応

#8です

こんばんは

補足要求です。

No5です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

エクセル２つの列にある値の完全一致を抜き出すVBA