照合した結果によって決めた値を転記するマクロ

Question

シート１には
Ａ～Ｆ列まで値があり、行数は都度相違し約15,000行くらい。
データは2行目から開始です。
シート２には
Ａ～ＡＥ列まで値があり、行数は都度相違し約5,000～25,000行
あり同じくデータは２行目からです。

シート１の行ごとに
A列,B列,C列の順で連結した値と
シート２の行ごとに
F列,G列,B列の順で連結した値を
照合させます。

その値が
（１）シート１にもシート２にもある場合は
　　シート２のＡＦ列に１と転記
（２）シート１には無いがシート２にはある場合は
　　シート２のＡＦ列に２と転記
（３）シート１には有るがシート２には無い場合は
　　シート２のＡＦ列に３と記入

シート２のデータのある行まで
作業を繰り返すマクロの記述を教えてください。

VLOOKUPを使用したマクロを作成しましたが
判定1,2,3の転記がうまく出来ないのと
VLOOKUPが重すぎて処理が遅すぎるので
速く処理が出来るとうれしいです。

例
シート１
A2=XXXX
B2=1234
C2=5678

シ－ト２
B2=1234
F2=XXXX
G2=5678

シート１の値＝XXXX12345678
シート２の値＝XXXX12345678
照合する
↓（一致なので）
シート２のセルＡＦ2に１と転記

merlionXX · Accepted Answer

おはようございます。
見直してみたら無駄な箇所があったので修正しました。
これで同一データで0.4秒でした。
それから「非対称」って、かたっぽが「対象」なら「非対象」じゃないですか？

Sub test06()
‘　　Dim t As Single
‘　　t = Timer
　　Dim myDic As Object
　　Dim myV, myV2, myW, myX, myY
　　Dim i As Long, uw As Long, uv As Long
　　With Sheets("Sheet1")
　　　　myV = .Range("A2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　With Sheets("Sheet2")
　　　　myW = .Range("B2", .Cells(Rows.Count, "G").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myV2(1 To uv, 1 To 1) As String
　　ReDim myX(1 To uw, 1 To 1) As String
　　ReDim myY(1 To uv, 1 To 1) As String
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 1 To uv
　　　　myV2(i, 1) = myV(i, 1) & "!" & myV(i, 2) & "!" & myV(i, 3)
　　Next i
　　For i = 1 To uw
　　　　myDic(myW(i, 5) & "!" & myW(i, 6) & "!" & myW(i, 1)) = i
　　　　myX(i, 1) = "非対象"
　　Next i
　　For i = 1 To uv
　　　　If Not myDic.Exists(myV2(i, 1)) Then
　　　　　　myY(i, 1) = "再発行"
　　　　Else
　　　　　　myX(myDic(myV2(i, 1)), 1) = "対象"
　　　　End If
　　Next i
　　Application.ScreenUpdating = False
　　Sheets("Sheet2").Range("AF2").Resize(uw, 1).ClearContents
　　Sheets("Sheet2").Range("AF2").Resize(uw, 1).Value = myX
　　Sheets("Sheet1").Range("G2").Resize(uv, 1).ClearContents
　　Sheets("Sheet1").Range("G2").Resize(uv, 1).Value = myY
　　Application.ScreenUpdating = True
‘　　Debug.Print Timer - t
End Sub

ki-aaa · Answer

補足読みました。

Sheet2のキーの順番が違うのだと思います。

質問では次のように成っています。

>シ－ト２
>B2=1234
>F2=XXXX
>G2=5678

>シート１の値＝XXXX12345678
>シート２の値＝XXXX12345678

それで、Sheet1のきーは、A列→ B列→ C列
それで、Sheet2のきーは、F列→ B列→ G列

このようになっているか、確認してください。

merlionXX さんも同じ質問をやっているんですよね。

回答番号10のtest04を流しました。

まったく違う結果になりましたので、見直してみるとキーの順番が違いました。
それで次のように変更して流すと、同じ結果になりました。

For i = 1 To uw
        myW2(i, 1) = myW(i, 5) & "-" & myW(i, 1) & "-" & myW(i, 6)
    Next i

では、よろしくお願いします。

merlionXX · Answer

実際にどれくらい時間がかかるか大量のデータでテストしてみました。
Sheet1に5,000、Sheet2に10,000のデータだとSub test04()のような順列組み合わせでは、いくら配列内の処理でも20秒以上かかってしまい、ストレスを感じますね。
重複するデータがないとわかっているなら、ここはやはり皆さんおやりのようにDictionaryオブジェクトを使わない手はないと痛感しました。
以下のコードでは、同じデータで0.78秒でした。

Sub test05()
　　Dim t As Single
　　t = Timer
　　Dim myDic As Object
　　Dim myV, myV2, myW, myX, myY
　　Dim i As Long, uw As Long, uv As Long
　　With Sheets("Sheet1")
　　　　myV = .Range("A2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　With Sheets("Sheet2")
　　　　myW = .Range("B2", .Cells(Rows.Count, "G").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myV2(1 To uv, 1 To 1) As String
　　ReDim myX(1 To uw, 1 To 1) As String
　　ReDim myY(1 To uv, 1 To 1) As String
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 1 To uv
　　　　myV2(i, 1) = myV(i, 1) & "/" & myV(i, 2) & "/" & myV(i, 3)
　　Next i
　　For i = 1 To uw
　　　　myDic(myW(i, 5) & "/" & myW(i, 6) & "/" & myW(i, 1)) = i
　　Next i
　　For i = 1 To uv
　　　　If Not myDic.Exists(myV2(i, 1)) Then
　　　　　　myY(i, 1) = "再発行"
　　　　Else
　　　　　　myX(myDic(myV2(i, 1)), 1) = "対象"
　　　　End If
　　Next i
　　For i = 1 To uw
　　　　If myX(i, 1) = Empty Then
　　　　　　myX(i, 1) = "非対称"
　　　　End If
　　Next i
　　Application.ScreenUpdating = False
　　Sheets("Sheet2").Range("AF2").Resize(uw, 1).ClearContents
　　Sheets("Sheet2").Range("AF2").Resize(uw, 1).Value = myX
　　Sheets("Sheet1").Range("G2").Resize(uv, 1).ClearContents
　　Sheets("Sheet1").Range("G2").Resize(uv, 1).Value = myY
　　Application.ScreenUpdating = True
　　Debug.Print Timer - t
End Sub

ki-aaa · Answer

補足、ありがとうございます。

意図したものと違う結果が出るデータは大量にあるのでしょうか。

テストデータではうまく行ったのでしょうか。

後考えられるのは、データの型の問題かな・・・。

問題のあるデータをプリントしてみる他ないかな。方法は下に書きます。
'*****ここから　'*****ここまで を追加する。
データを目視で調べる。

Set dic = Nothing   
    '*****ここから
    'Sheet1の問題のあるデータが、100行目にあったら
    i = 100 - 1
    Debug.Print "@abc @" & a_b_c(i, 1) & a_b_c(i, 2) & a_b_c(i, 3)
    
    'それに対応するSheet2の問題データが220行にあったら
    i = 220 - 1
    Debug.Print "@fbg @" & f_g(i, 1) & b_b(i, 1) & f_g(i, 2)
    '*****ここまで   
End Sub

この質問とは関係ないですが
end-uさんの書かれた、一定間隔で実行する方法も
使っています。感謝しています。

end-u · Answer

>またシート１ですが
>シート１にもシート２にもある物の行以降で
>シート２に無い物の行があると、この３の転記の判定をしません。
失礼。
>Sheets("Sheet1").Range("G1").Resize(mx).Value = w
この箇所、以下に修正必要です。
Sheets("Sheet1").Range("G1").Resize(UBound(w)).Value = w

また、照合結果を文字列にするなら
書き出し用配列の型をString型かVariant型に修正しなければいけません。
Dim w() As String
Dim x() As String

>まずいです。
１行目か２行目かの違いについては気づいてたのですが、
そこも修正回答必要ですか？
そこくらいは自分で修正できないと、
そのマクロは使えないんじゃないかと思いますけど。
失敗してもいいように、コピーしたファイルで色々試してみないと身につかないのでは。
Q6327342では自分で変更したりして、応用されてましたよね。

merlionXX · Answer

おや、追加リクエストがあったんですね、気づきませんでした。

> また上記の推測もあっていますでしょうか？
> 数字は下手に書き換えると行数や列数やセル位置を
> 示す場合もあり、怖いです。

ならばテストデータで試してみたらいかがでしょう？
こちらもあなたの質問に答えるためにテストデータをわざわざ作成してるのです。
ま、一応回答しておきますね。
今日はなんとお昼からお座敷がかかっています（笑）

Sub test04()
　　Dim myV, myV2, myW, myW2, myX, myY
　　Dim i As Long, n As Long, uw As Long, uv As Long
　　With Sheets("Sheet1")
　　　　myV = .Range("A2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　With Sheets("Sheet2")
　　　　myW = .Range("B2", .Cells(Rows.Count, "G").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myV2(1 To uv, 1 To 1)
　　ReDim myW2(1 To uw, 1 To 1)
　　ReDim myX(1 To uw, 1 To 1)
　　ReDim myY(1 To uv, 1 To 1)
　　For i = 1 To uv
　　　　myV2(i, 1) = myV(i, 1) & "-" & myV(i, 2) & "-" & myV(i, 3)
　　Next i
　　Erase myV
　　For i = 1 To uw
　　　　myW2(i, 1) = myW(i, 5) & "-" & myW(i, 6) & "-" & myW(i, 1)
　　Next i
　　Erase myW
　　For i = 1 To uv
　　　　For n = 1 To uw
　　　　　　If myV2(i, 1) = myW2(n, 1) Then
　　　　　　　　myX(n, 1) = "対象"
　　　　　　　　myY(i, 1) = "ダミー"
　　　　　　End If
　　　　Next n
　　Next i
　　Erase myV2, myW2
　　For n = 1 To uw
　　　　If myX(n, 1) = Empty Then
　　　　　　myX(n, 1) = "非対称"
　　　　End If
　　Next n
　　For n = 1 To uv
　　　　If myY(n, 1) = Empty Then
　　　　　　myY(n, 1) = "再発行"
　　　　Else
　　　　　　myY(n, 1) = Empty '"ダミー"の消去
　　　　End If
　　Next n
　　Sheets("Sheet2").Range("AF2").Resize(uw, 1).Value = myX
　　Sheets("Sheet1").Range("G2").Resize(uv, 1).Value = myY
　　Erase myX, myY
End Sub

merlionXX · Answer

gx9wxさん、おはようございます。
昨夜のコードで成功してよかった。そうですか、1秒かかりませんでしたか。

ところで、Sheet1のA、B、C列の結合データと、Sheet2のF、G、B列の結合データのマッチングをやったわけですが、こんなケースはありますか？

例
Sheet1のA、B、C列→AAA + BBB + CCC
Sheet2のF、G、B列→A + AABB + BCCC
つまり、それぞれの列ではまったく違うデータなのに、結合させると同じになってしまうケースです。
end-uさんの、その点をちゃんと手当てしているコードをみて、はたと気づきました。

わたしのコードだと、それは想定外なので同じと判定してしまいます。
一応、気になったので修正しておきます。
ついでに何度もUboundの同じ計算をさせていたのを
　　uv = UBound(myV)
　　uw = UBound(myW)
と、変数に代入して一度で済ませるようにしました。

Sub test03()
　　Dim myV, myV2, myW, myW2, myX, myY
　　Dim i As Long, n As Long, uw As Long, uv As Long
　　With Sheets("Sheet1")
　　　　myV = .Range("A2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　With Sheets("Sheet2")
　　　　myW = .Range("B2", .Cells(Rows.Count, "G").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myV2(1 To uv, 1 To 1)
　　ReDim myW2(1 To uw, 1 To 1)
　　ReDim myX(1 To uw, 1 To 1)
　　ReDim myY(1 To uv, 1 To 1)
　　For i = 1 To uv
　　　　myV2(i, 1) = myV(i, 1) & "-" & myV(i, 2) & "-" & myV(i, 3)
　　Next i
　　Erase myV
　　For i = 1 To uw
　　　　myW2(i, 1) = myW(i, 5) & "-" & myW(i, 6) & "-" & myW(i, 1)
　　Next i
　　Erase myW
　　For i = 1 To uv
　　　　For n = 1 To uw
　　　　　　If myV2(i, 1) = myW2(n, 1) Then
　　　　　　　　myX(n, 1) = 1
　　　　　　　　myY(i, 1) = 4
　　　　　　End If
　　　　Next n
　　Next i
　　Erase myV2, myW2
　　For n = 1 To uw
　　　　If myX(n, 1) = Empty Then
　　　　　　myX(n, 1) = 2
　　　　End If
　　Next n
　　For n = 1 To uv
　　　　If myY(n, 1) = Empty Then
　　　　　　myY(n, 1) = 3
　　　　Else
　　　　　　myY(n, 1) = Empty
　　　　End If
　　Next n
　　Sheets("Sheet2").Range("AF2").Resize(uw, 1).Value = myX
　　Sheets("Sheet1").Range("G2").Resize(uv, 1).Value = myY
　　Erase myX, myY
End Sub

ki-aaa · Answer

試してもらって、ありがとう。

回答の修正と補足

>.Range("AE2:AF" & 行).ClearContents
↓
.Range("AF2:AF" & 行).ClearContents

>'*****これ以下はSheet2に有り、Sheet1に無いものを探す。
↓
'*****これ以下はSheet1に有り、Sheet2に無いものを探す。

>.Range("AE2:AF" & UBound(a_b_c) + 1).ClearContents
>.Range("AF2:AF" & UBound(a_b_c) + 1).Value = a_f_1
↓
.Range("G2:G" & UBound(a_b_c) + 1).ClearContents
.Range("G2:G" & UBound(a_b_c) + 1).Value = a_f_1

merlionXX · Answer

> その場合はシート１のＧ列に３と記入したいです。

こんばんは。
もう回答が出揃っているようですが、補足をいただきましたので、それをうけて再回答します。

Sub test02()
　　Dim myV, myV2, myW, myW2, myX, myY
　　Dim i As Long, n As Long
　　With Sheets("Sheet1")
　　　　myV = .Range("A2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　With Sheets("Sheet2")
　　　　myW = .Range("B2", .Cells(Rows.Count, "G").End(xlUp)).Value
　　End With
　　ReDim myV2(1 To UBound(myV), 1 To 1)
　　ReDim myW2(1 To UBound(myW), 1 To 1)
　　ReDim myX(1 To UBound(myW), 1 To 1)
　　ReDim myY(1 To UBound(myV), 1 To 1)
　　For i = 1 To UBound(myV2)
　　　　myV2(i, 1) = myV(i, 1) & myV(i, 2) & myV(i, 3)
　　Next i
　　Erase myV
　　For i = 1 To UBound(myW2)
　　　　myW2(i, 1) = myW(i, 5) & myW(i, 6) & myW(i, 1)
　　Next i
　　Erase myW
　　For i = 1 To UBound(myV2)
　　　　For n = 1 To UBound(myW2)
　　　　　　If myV2(i, 1) = myW2(n, 1) Then
　　　　　　　　myX(n, 1) = 1
　　　　　　　　myY(i, 1) = 4
　　　　　　End If
　　　　Next n
　　Next i
　　Erase myV2, myW2
　　For n = 1 To UBound(myX)
　　　　If myX(n, 1) = Empty Then
　　　　　　myX(n, 1) = 2
　　　　End If
　　Next n
　　For n = 1 To UBound(myY)
　　　　If myY(n, 1) = Empty Then
　　　　　　myY(n, 1) = 3
　　　　Else
　　　　　　myY(n, 1) = Empty
　　　　End If
　　Next n
　　Sheets("Sheet2").Range("AF2").Resize(UBound(myX), 1).Value = myX
　　Sheets("Sheet1").Range("G2").Resize(UBound(myY), 1).Value = myY
　　Erase myX, myY
End Sub

end-u · Answer

Sub try()
　　Dim dic As Object 'Scripting.Dictionary
　　Dim s　 As String '文字列連結用
　　Dim mx　As Long　 '配列添字最大値
　　Dim i　 As Long
　　Dim v　 As Variant '取得用配列
　　Dim w() As Variant 'Sheet1書き出し用
　　Dim x() As Long　　'Sheet2書き出し用
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　'"Sheet1"の範囲を配列に取得
　　With Sheets("Sheet1")
　　　　'A列がデータ有無判定基準の場合。
　　　　'A列にデータがある範囲を取得し、右に3列広げる。
　　　　v = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 3).Value
　　End With
　　
　　'配列をLoopして３つのキーを連結した文字列をDictionaryに登録。
　　'と同時に同サイズのLong型配列に 3 を入れる。
　　'dicのitemには配列の位置を記録しておく。
　　mx = UBound(v)
　　ReDim w(1 To mx, 1 To 1)
　　For i = 1 To mx
　　　　s = v(i, 1) & "|" & v(i, 2) & "|" & v(i, 3)
　　　　dic(s) = i
　　　　w(i, 1) = 3
　　Next
　　　　
　　'"Sheet2"の範囲を配列に取得
　　With Sheets("Sheet2")
　　　　'B列がデータ有無判定基準の場合。
　　　　'B列にデータがある範囲を取得し、右に6列広げる。
　　　　v = .Range("B1", .Range("B65536").End(xlUp)).Resize(, 6).Value
　　End With
　　
　　'配列をLoopして３つのキーを連結した文字列をDictionaryで照合。
　　'同サイズのLong型配列に判定結果を入れる。
　　mx = UBound(v)
　　ReDim x(1 To mx, 1 To 1)
　　For i = 1 To mx
　　　　s = v(i, 5) & "|" & v(i, 6) & "|" & v(i, 1)
　　　　If dic.Exists(s) Then
　　　　　　'登録があればSheet2側の配列xに 1 をセット。
　　　　　　x(i, 1) = 1
　　　　　　'3を入れてあるSheet1側の配列wに Empty をセット。
　　　　　　'wへのセット位置は dic(s)のitemに記録ずみ。
　　　　　　w(dic(s), 1) = Empty
　　　　Else
　　　　　　x(i, 1) = 2
　　　　End If
　　Next
　　
　　Sheets("Sheet1").Range("G1").Resize(mx).Value = w
　　Sheets("Sheet2").Range("AF1").Resize(mx).Value = x
　
　　Erase w, x
　　Set dic = Nothing
End Sub

Dictionaryの理解の前に、配列処理に対して理解しておいたほうが良かったですね。

Variant型変数に　v = Range(連続した複数範囲).Value　などのように
セル複数範囲の値を入れると２次元配列になります。
この時、配列のインデックスは１から始まります。

２次元配列に関しては、メモリ上にあるセル範囲のようなものを想像してください。
Sheet2の場合は
~~~~~~
v = .Range("B1", .Range("B65536").End(xlUp)).Resize(, 6).Value
v(1, 1)にB1セル、v(2, 1)にC1セル、v(3, 1) にD1セルの値が入っています。
この時の(1, 1)というのがアドレスみたいなもので、
それによって配列（メモリ上の矩形範囲）のどの場所かを指定するわけです。
Loop内の
s = v(i, 5) & "|" & v(i, 6) & "|" & v(i, 1)
この処理で、タテ方向i番目のヨコ方向 5,6,1 列の値、
つまりF,G,B列の値を連結してます。

照合した結果によって決めた値を転記するマクロ

おはようございます。

この回答への補足

補足読みました。

この回答への補足

実際にどれくらい時間がかかるか大量のデータでテストしてみました。

この回答への補足

補足、ありがとうございます。

>またシート１ですが

この回答への補足

おや、追加リクエストがあったんですね、気づきませんでした。

この回答への補足

gx9wxさん、おはようございます。

この回答への補足

試してもらって、ありがとう。

この回答への補足

> その場合はシート１のＧ列に３と記入したいです。

この回答への補足

Sub try()

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

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

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

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