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

質問

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

ki-aaa

補足読みました。

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

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

お礼

お手数かけました。
どうもありがとうございました。

補足

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

はいそうのとうりです。

お手数かけて申し訳ありません。

回答No.13

merlionXX

実際にどれくらい時間がかかるか大量のデータでテストしてみました。
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

お礼

ありがとうございます。
別のマクロ作成にはまっていて
（もうギブアップ）
実験していません。
本日修正版がｕｐされてましたので
そちらで実験いたします。

補足

end-uさんの修正版は1秒かからなかったです。
ki-aaaさんの記述も1秒かからなかったです。
ki-aaaさんの物は私の説明が悪く誤処理でしたが
今修正版をくれました。
多分、修正版も1秒以内は変わらないと思います。
merlionXXさんも修正版をくれました。
これも1秒以内となるとどれを使用しても
いいのですね。
お手数かけました。
あれっ。お座敷だったのでは？
お忙しいのにすいません。

回答No.12

ki-aaa

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

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

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

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

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

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さんの書かれた、一定間隔で実行する方法も
使っています。感謝しています。

お礼

ありがとうございます。すいません。

説明が下手ですいません。（かえって混乱したらすいません。）

シート１（シート２）
A列（B列）→型番１０桁
B列（F列）→仕入先コード４桁
C列（G列）→メーカーコード４桁
です。

ですから本来、シート１のA列とシート２のB列を照合させればいいのですが
同じ型番でも仕入先が違う、メーカーが違う場合があるので
それだけだと重複行が発生します。

AAAAAAAAAA　1111　1111
AAAAAAAAAA　1111　2222
AAAAAAAAAA　3333　1111

これらはA列（B列）が同じでも違う物としてそれぞれ照合したいのです。

で、教えていただいた記述では
AAAAAAAAAA　1111　1111の場合
は問題ありません。
AAAAAAAAAA　1111　2222
や
AAAAAAAAAA　3333　1111
の時に駄目なのです。
型番ではなく
仕入先コードの4桁と
メーカーコードの4桁が違う場合です。

シート１もシート２にも
AAAAAAAAAA　1111　2222
があれば同じ値とみなすので、
シート２のAF列には１が転記のはずですが
２（シート１にはない）と転記され
シート１のＧ列は空白のはずが
３（シート２には無い）と転記されます。
5,000行の中で4,000行くらいが
このパターン（仕入先とメーカーコードが相違する）の為、
ほとんど駄目でした。

正規の状態例

シート１
AAAAAAAAAA　1111　1111→シート２にある→G列は空白
AAAAAAAAAA　1111　2222→シート２にある→G列は空白
BBBBBBBBBB　2222　2222→シート２にある→G列は空白
CCCCCCCCCC　1111　5555→シート２にない→G列は３
DDDDDDDDDD　6666　6666→シート２にない→G列は３

シート２
AAAAAAAAAA　1111　1111→シート１にある→AF列は１
AAAAAAAAAA　1111　2222→シート１にある→AF列は１
BBBBBBBBBB　2222　2222→シート１にある→AF列は１
EEEEEEEEEE　1111　3333→シート２にない→AF列は２

↓現在　●印部分が間違い判定
シート１
AAAAAAAAAA　1111　1111→シート２にある→G列は空白
AAAAAAAAAA　1111　2222→シート２にある→G列は空白→３●
BBBBBBBBBB　2222　2222→シート２にある→G列は空白
CCCCCCCCCC　1111　5555→シート２にない→G列は３
DDDDDDDDDD　6666　6666→シート２にない→G列は３

シート２
AAAAAAAAAA　1111　1111→シート１にある→AF列は１
AAAAAAAAAA　1111　2222→シート１にある→AF列は１→２●
BBBBBBBBBB　2222　2222→シート１にある→AF列は１
EEEEEEEEEE　1111　3333→シート２にない→AF列は２

回答No.11

end-u

>またシート１ですが
>シート１にもシート２にもある物の行以降で
>シート２に無い物の行があると、この３の転記の判定をしません。
失礼。
>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では自分で変更したりして、応用されてましたよね。

お礼

>>Sheets("Sheet1").Range("G1").Resize(mx).Value = w
>この箇所、以下に修正必要です。
>Sheets("Sheet1").Range("G1").Resize(UBound(w)).Value = w

これで正しく動きました。

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

ありがとうございます。

>そこくらいは自分で修正できないと

申し訳ありません。（泣）
教えていただいた記述の書換恐怖症になっています。（泣）
本当にごめんなさい（泣）

Sheets("Sheet1").Range("G1").Resize(UBound(w)).Value = w
Sheets("Sheet2").Range("AF1").Resize(mx).Value = x
この部分が結果を転記する部分ですよね。
ここを
Sheets("Sheet1").Range("G2").Resize(UBound(w)).Value = w
Sheets("Sheet2").Range("AF2").Resize(mx).Value = x
にしたら
転記開始行は2行目になりましたが1行目の照合結果が
２行目に転記され、結果1行づつずれてデータの無い
最終行からもう1行目にも転記されていました。
という事は
配列をLoopして３つのキーを連結した文字列をDictionaryで照合
した時点ですでにしなくていい1行目の照合結果が
登録されたのだと思い、どこでそれがされているか？

'A列にデータがある範囲を取得し、右に3列広げる。
v = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 3).Value
End With
'B列にデータがある範囲を取得し、右に6列広げる。
v = .Range("B1", .Range("B65536").End(xlUp)).Resize(, 6).Value
End With

ここだと思い、
v = .Range("A2", .Range("A65536").End(xlUp)).Resize(, 3).Value
End With
'B列にデータがある範囲を取得し、右に6列広げる。
v = .Range("B2", .Range("B65536").End(xlUp)).Resize(, 6).Value
としたら正しく動作しました。

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

補足

シート１が約５，３００行
シート２が約５，７００行
で1秒かかりませんでした。
どうもありがとうございます。

回答No.10

merlionXX

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

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

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

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

お礼

漢字でいれてもらって、
私の予想とは全然違いました。
どうもありがとうございました。

補足

＞ならばテストデータで試してみたらいかがでしょう？
＞こちらもあなたの質問に答えるためにテストデータを
＞わざわざ作成してるのです。

本当にごめんなさい。
いつもテストデータで試して駄目だと質問しますが
今回はテストデータで試す所までいけませんでした。
1の転記が分からなくて。（泣）

えっつ。お昼から．．．．．(゜o゜)

今別の物もやっていて、
万歳になったらスレッドを立ち上げようと思いましたが
月曜にします。．．．．．．．．(-_-;)
ずうずうしくてすいません。m(__)m

回答No.9

merlionXX

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

お礼

ありがとうございました。
シート２が１０，０００行、シート１が５，０００行で
２０秒かかります。
シート１の５，０００行のうち半分くらいが３です。
現在思ったとおり動作するのがmerlionXXさんの記述だけの為
これでいきます。
ちなみにVLOOKUPでは５～１０分なので
２０秒はかなり早いです。

補足

>Sheet1のA、B、C列→AAA + BBB + CCC
>Sheet2のF、G、B列→A + AABB + BCCC
>つまり、それぞれの列ではまったく違うデータなのに、結合させると同じになって>しまうケースです。

すいません。ありがとうございます。
そういうケースは絶対ないです。
それぞれ固定長です。
また各列値の役割が違うので
絶対無いです。

＞ついでに何度もUboundの同じ計算をさせていたのを
＞　　uv = UBound(myV)
＞　　uw = UBound(myW)
＞と、変数に代入して一度で済ませるようにしました。

3,000行くらいだと秒速ですが
10,000行くらいだと２０秒かかっています。
03で速くなるか試します。

回答No.8

ki-aaa

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

回答の修正と補足

>.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

お礼

わざわざすいません。
テストは
シート１が８行、シート２が６行で行いました。
１，２，３全て思ったとおり正しく転記されました。

で本番環境、
シート１が３，５００行、シート２が２，５００行でしたが
１秒かかりません。
これから20,000行クラスで挑戦します。
どうもありがとうございました。

補足

申し訳ありません。
テストデータのパターンは
シート１
A2=AAAA
B2=1234
C2=1234

シ－ト２
B2=1234
F2=AAAA
G2=1234

シート１の値＝AAAA12341234
シート２の値＝AAAA12341234

↓（一致なので）
シート２のセルＡＦ2に１と転記

でうまくいったのですが以下のような場合

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

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

シート１の値＝XXXX12345678
シート２の値＝XXXX12345678
照合すると一致なので
↓
シート２のセルＡＦ２に１と転記のはずが
２と転記され、かつ
シート１のＧ２は空白のはずが３と転記されます。

シート１にあってシート２に無い場合の
シート１のＧ列に３と転記は問題ないのですが
シート１にもシート２にも有る場合で上記のパターンの時
が駄目でした。

速度は20,000行でも1秒かかってません。

回答No.7

merlionXX

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

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

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

お礼

完璧です。

テストは
シート１が８行、シート２が６行で行いました。
１，２，３全て思ったとおり正しく転記されました。

で本番環境、
シート１が３，５００行、シート２が２，５００行でしたが
１秒かかりません。
あのめちゃくちゃな質問に対応していただき
感謝いたしております。
どうもありがとうございました。

補足

わがままですいません。
１→対象
２→非対称
３→再発行
に変更しようと思い

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
を

If myX(n, 1) = Empty Then
　　　　　　myX(n, 1) = "非対称"
　　　　End If
　　Next n
　　For n = 1 To UBound(myY)
　　　　If myY(n, 1) = Empty Then
　　　　　　myY(n, 1) = "再発行"

なのかなと推測していますが
１と転記する１に該当するがどこなのかわかりません。
また上記の推測もあっていますでしょうか？
数字は下手に書き換えると行数や列数やセル位置を
示す場合もあり、怖いです。

１，２，３を変更するのはユーザーリクエストですが
私も記述を理解するのに
１，２，３より漢字名称の方がいいなあと思いました。

お手数おかけします。m(__)m

PS　今日は週末ですがお座敷でしょうか．．．．．

回答No.6

end-u

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列の値を連結してます。

お礼

ありがとうございます。
配列処理の事を教えていただいて
ありがとうございます。
でも、まだよくわかりません。

あと結果なのですが
（スレッド最初の質問内容が悪くてすいません）

まずシート２ですが
ＡＦ列の1行目セルＡＦ１に２と転記されます。
データは２行目からなので、ここに２と転記ではまずいです。

シート１には有ってシート２には無い場合
シート１のＧ列に３と転記ですが
同じくＧ列1行目セルＧ１に３と転記されます。
データは２行目からなので、ここに３と転記ではまずいです。

またシート１ですが
シート１にもシート２にもある物の行以降で
シート２に無い物の行があると、この３の転記の判定をしません。

シート１
２行目シート２にない→シート１のＧ２に３と転記
３行目シート２にない→シート１のＧ３に３と転記
４行目シート２に有る→シート２のＡＦ４に１と転記
　　　　　　　　　　　シート１のＧ４は空白　
５行目シート２に有る→シート２のＡＦ５に１と転記
　　　　　　　　　　　シート１のＧ５は空白　
６行目シート２にない→シート１のＧ６に３と転記のはずが空白
７行目シート２にない→シート１のＧ６に３と転記のはずが空白

回答No.5

ki-aaa

間違いがありました。

>.Range("AE2:AF" & UBound(a_b_c) + 1).ClearContents
↓
.Range("AF2:AF" & UBound(a_b_c) + 1).ClearContents

お礼

ありがとうございます。
こちらで試しました。

私の質問の不備である
A-NO.3の補足の
以下の内容が駄目でした。

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

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