Excelにて、シート間で、データーを比較して、一致したら別シートへ転記するコードを教えてください。

Excelにて、シート間で、データーを比較して、一致したら一致シートへ転記し一致しないものは一致しないシートヘ転記するするコードを教えてください。

詳細
Excelにて、シート間で、データーを比較して、一致したら一致シートへ転記し一致しないものは一致しないシートヘ転記するVBAコード作ってみたのですが、うまくいきません。
どなたか、お分かりになる方、ご教授願います。

'検索値があるシート（バーコード）'対象データがあるシート（sheet1）
　'一致結果を出力するシート（マッチングデーター）、一致しない結果を出力するシート（マッチング外データー）となっています。

VBAコード作ってみたのですが、うまくいきません。

＜不具合点＞
①データーを比較してくれない
⇒検索値があるシート（バーコード）のデーター（B列）と対象データがあるシート（sheet1）
の列データー（E列）を比較してマッチングデーターシートヘ転記してくれない。
それぞれの列のデーターは、その都度増減します。
②一致しない結果を出力するシート（マッチング外データー）へ転記しない。

その他
⇒検索値があるシート（バーコード）のデーターは、バーコードリーダーを使いバーコードを読み取り、
A列に読み取り値があります、その値をB列で、比較に下4桁を使用するので、下4桁を取り出しています。
して、対象データがあるシート（sheet1）のデーターと比較しています。

B列には、=IFERROR( VALUE(RIGHT(A2,4)),"")で、4桁を取り出しています。

◇検索値があるシート（バーコード）

　　　　Ａ　　　　　Ｂ　　　　Ｃ　　　　Ｄ
１　　バーコード　　連番
※連番のデーターで比較


◇データーと対象データがあるシート（sheet1）

　　　　Ａ　　　　　Ｂ　　　　　　　Ｃ　　　　　　Ｄ　　　　　　　E・・・　　　Ｙまで
１　　発行元 発行元名 　　生産計画情報　 発行情報　　 連番 　次工程
※連番のデーターで比較
※画像左が、バーコードシート、画像右がsheet1です。
画像参照願います。

おもうようにいかず困っております。
説明がうまくなくて、すみませんが、よろしくお願いします。

Sub Sample3()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim sh As Worksheet
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("バーコード")
With sh1
For i = 2 To .Cells(Rows.Count, "E").End(xlUp).Row
If .Range("E" & i).Value = sh2.Range("B" & i).Value Then
Set sh = Worksheets("マッチングデーター")
Else
Set sh = Worksheets("マッチング外データー")
End If
j = sh.Cells(Rows.Count, "E").End(xlUp).Row + 1
.Range("A" & i & ":S" & i).copy Destination:=sh.Range("A" & j)
Next i
End With
Application.ScreenUpdating = True
End Sub

No.1 ベストアンサー 回答者： fujillin 回答日時： 2020/01/24 13:35

こんにちは

内容がよくわからなかったので、勝手に想定しました。
『データシートの各行のデータ（Ａ：Ｓ列）をＥ列の値によって振り分けてコピーしたい』
振り分けの条件は、「バーコード一シート」のＢ列の一覧に乗っているか否かで、記載があれば「マッチシート」へ、一覧に記載が無ければ「非マッチシート」へ。
というものと仮定しました。

各シートの1行目はタイトル行と仮定。
方法としては、
「関数で仕分けして、その結果をオートフィルタでフィルタしてコピペ」
という手順です。

Sub Sample()
Dim absent, presnt, bar, sh1
Dim data As Range, f As String, tmpC As Long

'--- シート変数セット
Set bar = Worksheets("バーコード") ' バーコードシート
Set sh1 = Worksheets("Sheet1") ' データシート
Set presnt = Worksheets("マッチングデーター") ' マッチデータのシート
Set absent = Worksheets("マッチング外データー") ' 非マッチデータのシート
tmpC = WorksheetFunction.Min(sh1.UsedRange.Columns.Count + 1, Columns.Count)

'---　データ仕分け（抽出）
Set data = sh1.Cells(2, 1).Resize(sh1.Cells(Rows.Count, 5).End(xlUp).Row - 1, tmpC)
f = bar.Cells(2, 2).Resize(bar.Cells(Rows.Count, 2).End(xlUp).Row - 1, 1).Address()
f = "=IF(E2="""","""",(COUNTIF(" & bar.Name & "!" & f & ",E2)>0)*1)"
sh1.Cells(2, tmpC).Resize(data.Rows.Count).FormulaLocal = f

'---　データコピー
Set data = data.Offset(-1).Resize(data.Rows.Count + 1)
data.AutoFilter
data.AutoFilter Field:=tmpC, Criteria1:=0
data.Columns("A:S").Copy Destination:=absent.Cells(1, 1)
data.AutoFilter
data.AutoFilter Field:=tmpC, Criteria1:=1
data.Columns("A:S").Copy Destination:=presnt.Cells(1, 1)
data.AutoFilter
sh1.Columns(tmpC).Clear

End Sub

※ コピペ先のシートへは1行目からペーストしていますが、最初にクリアする必要がある場合はクリアしてからコピペするようにしてください。
※ 既に記入されているデータがあって、その後ろに追加してゆく方式の場合は、Destinateionのセルを最終行+1に指定すればそのようになります。
※ セル値を単純にコピペしていますので、関数式が設定されている場合などに有効でなくなってしまうケースがあります。そのような場合には「値をペースト」にするのが効果的と思います。

この回答へのお礼

対応して頂き誠にありがとうございました。
説明がうまくできない中、思い通りの結果となりましたこと
心から感謝いたします。

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

お礼日時：2020/01/25 12:48