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

質問

シート１には
Ａ～Ｆ列まで値があり、行数は都度相違し約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に１と転記

回答No.15

merlionXX · ベストアンサー

おはようございます。
見直してみたら無駄な箇所があったので修正しました。
これで同一データで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

お礼

Sub test04()と比べました。

Sub test04()→２５秒
Sub test06()→1秒以内

また結果も双方同じでした。

ありがとうございました。

補足

はははは。（笑）
＞「非対称」って、かたっぽが「対象」なら「非対象」
私の誤記は永久に直りません。(ToT)/~~~
見直してもその時はおかしいと思わない？
投稿後読み直すと気がつきます。
もしくは指摘されてから。
いつもすいません。

回答No.4

ki-aaa

つい最近、dictionaryを使った検索をこのサイトで勉強しましたので、
試してください。

Sub ■dictest_2()
Dim dic As Object
Dim i As Long
Dim a_b_c, b_b, f_g, a_f_1, a_f_2
Dim 行 As Long

With Sheets("Sheet1")
行 = .Range("A" & Rows.Count).End(xlUp).Row
a_b_c = .Range("A2:C" & 行).Value
ReDim a_f_1(1 To UBound(a_b_c), 1 To 1)
End With

Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(a_b_c)
dic.Add "@" & a_b_c(i, 1) & a_b_c(i, 2) & a_b_c(i, 3), i
'"@"をつけるのは、八桁以上の数字のみだと非常に遅くなるから
Next
With Sheets("Sheet2")
行 = .Range("B" & Rows.Count).End(xlUp).Row
b_b = .Range("B2:B" & 行).Value
f_g = .Range("F2:G" & 行).Value
ReDim a_f_2(1 To UBound(b_b), 1 To 1)

For i = 1 To UBound(b_b)
If dic.exists("@" & f_g(i, 1) & b_b(i, 1) & f_g(i, 2)) Then
a_f_2(i, 1) = 1
Else
a_f_2(i, 1) = 2
End If
Next
.Range("AE2:AF" & 行).ClearContents
.Range("AF2:AF" & 行).Value = a_f_2
End With
Set dic = Nothing

'*****これ以下はSheet2に有り、Sheet1に無いものを探す。
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(b_b)
dic.Add "@" & f_g(i, 1) & b_b(i, 1) & f_g(i, 2), i
Next
For i = 1 To UBound(a_b_c)
If Not dic.exists("@" & a_b_c(i, 1) & a_b_c(i, 2) & a_b_c(i, 3)) Then
a_f_1(i, 1) = 3
End If
Next
With Sheets("Sheet1")
.Range("AE2:AF" & UBound(a_b_c) + 1).ClearContents
.Range("AF2:AF" & UBound(a_b_c) + 1).Value = a_f_1
End With
Set dic = Nothing

End Sub

お礼

ありがとうございます。
瞬時に終了しました。
A-NO.3の補足の
以下の内容が駄目でした。

>>３．「シート１には有るがシート２には無い場合は
>>シート２のＡＦ列に３と記入」
>>としているが、
>>いったいSheet2のどの行に入れさせるおつもりなのか？

>申し訳ありません。出来るわけ有りませんでした。
>その場合はシート１のＧ列に３と記入したいです。

回答No.3

merlionXX

質問では不明確な点がいくつかあります。
自分はわかっていることでも他の人はまったく知らないのだということを忘れずに、質問を推敲してから投稿するようにしましょう。

１．行ごとに照合とは、Sheet1とSheet2の同じ行で比較するのか、行を問わないのか？
（両シートの行数が違うようなので、行を問わず、総当りで照合するのだろうとは想像しますが・・・・）

２．同じシートに重複があった場合はどうするのか？
挙げられた例で、シート２の値＝XXXX12345678が、Sheet2に複数あった場合は、最初の行のAF列に入力させるだけでいいのか、重複する全部のAF列に入力させるのか？はたまた重複はありえないのか。

３．「シート１には有るがシート２には無い場合はシート２のＡＦ列に３と記入」としているが、いったいSheet2のどの行に入れさせるおつもりなのか？

４．データに空白行や空白列がある可能性はあるのかないのか？

これだけ不明確な点があったら、普通はコードを書く気にはなれませんが、とりあえず
・行は問わずに総当り検索
・重複にも記入
・シート１には有るがシート２には無い場合はどこに記入するかわからないので無視
・すくなくとも対象列の最終行は空白ではない。
という前提で書きました。
VLOOKUPではなく配列に取り込んでマッチングさせていますからそんなに時間はかからないのではと思いますが、試してみてください。

Sub test01()
　　Dim myV, myV2, myW, myW2, myX
　　Dim i As Long, n As Long, j 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)
　　For i = 1 To UBound(myV2)
　　　　myV2(i, 1) = myV(i, 1) & myV(i, 2) & myV(i, 3)
　　Next i
　　For i = 1 To UBound(myW2)
　　　　myW2(i, 1) = myW(i, 5) & myW(i, 6) & myW(i, 1)
　　Next i
　　For i = 1 To UBound(myV2)
　　　　For n = 1 To UBound(myW2)
　　　　　　If myV2(i, 1) = myW2(n, 1) Then
　　　　　　　　myX(n, 1) = 1
　　　　　　End If
　　　　Next n
　　Next i
　　For n = 1 To UBound(myX)
　　　　If myX(n, 1) = Empty Then
　　　　　　myX(n, 1) = 2
　　　　End If
　　Next n
　　Sheets("Sheet2").Range("AF2").Resize(UBound(myX), 1).Value = myX
End Sub

お礼

質問がめちゃくちゃですいません。
補足に対応した回答をいただきましたので、
テストはそちらで行います。
どうもありがとうございました。

補足

いつもいつもすいません。m(__)m

>１．行ごとに照合とは、Sheet1とSheet2の同じ行で比較するのか、
>行を問わないのか？
>(両シートの行数が違うようなので、行を問わず、
>総当りで照合するのだろうとは想像しますが・・・・）

はい。総当りで照合です。

>２．同じシートに重複があった場合はどうするのか？
>挙げられた例で、シート２の値＝XXXX12345678が、
>Sheet2に複数あった場合は、
>最初の行のAF列に入力させるだけでいいのか、
>重複する全部のAF列に入力させるのか？
>はたまた重複はありえないのか。

同じシートでの重複は無いです。
その為３つのセルを結合させた値で照合をします。

>３．「シート１には有るがシート２には無い場合は
>シート２のＡＦ列に３と記入」
>としているが、
>いったいSheet2のどの行に入れさせるおつもりなのか？

申し訳ありません。出来るわけ有りませんでした。
その場合はシート１のＧ列に３と記入したいです。

>４．データに空白行や空白列がある可能性はあるのかないのか？

空白行はありません。
空白のセルはシート２でところどころにあります。
ですが照合対象となるF列,G列,B列には空白は絶対無いです。

回答No.2

いけだ ひろし（@ike-2000）

どのような運用か分かりませんが、愚直にマクロを書いてみてはどうでしょうか。

「Application.ScreenUpdating=False」を書いておけば後は(アルゴリズムと)CPUパワーです。
処理自体は単純そうなので普通にマクロを書いても2万件くらいなら１時間もあれば完了すると思います。

お礼

質問したのは最大のパターンで
通常はシート１、シート２共に最大３，５００行くらいです。

＞愚直にマクロを書いてみて

で１，２，３を転記する部分の記述がうまくできない（おかしな値が転記される）
ので速度だけではないのです。
ＶＬＯＯＫＵＰだと照合してヒットしたらその行の指定列を返すので
それを条件分岐にする？
ここら辺がよくわからず困っています。
遅い処理でもいいので、記述全体を教えていただきたかったのですが。

どうもありがとうございました。

回答No.1

aokii

データが多いので、アクセスをお勧めします。

お礼

アクセス。
触った事ないです。

シート１、シート２共に３，５００行くらいのもありますが
それでもアクセスの方がいいのでしょうか？

どうもありがとうございました。