ExcelVBAでデータ不一致のものの抽出

Sheet1「元データ」　　　　　　　　　　　　　　
　　　A　　　B　　 　C　　　D　　　　
1　 0001 みかん　 A店　　3/1　
2 0200　 りんご B店　
3 0311 いちご B店　　3/10
4 　　 いちじく C店
5 0360 メロン　　D店
6 かき　　　P店
7 　0312 キウイ　　D店
99 0333 くり　C店

Sheet2「最新データ」
　　A　　　B　　 　C　　　D
1　 0001 みかん　 A店　　3/1
2 0190
3 0200　
4 0311 いちご B店　　3/10
5 0422　 洋ナシ C店
6 0250
7 0500 すいか　　P店　
8 　0312 キウイ　　　
　　
とあった時に最新データのA列の番号と元データの番号を見て同じ物があったら、最新データに元データの内容をうつし込むというデータがあります。

Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Dim myR As Range
Dim N_D As Long
Dim i As Long
Set Sh1 = Worksheets("元データ")
Set Sh2 = Worksheets("新規データ")
Set Sh3 = Worksheets("最新データ")
With Sh3
For i = 5 To .Range("A65536").End(xlUp).Row
N_D = .Range("E" & i).Value
Set myR = Sh1.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _
MatchCase:=False)
If Not myR Is Nothing Then
myR.Offset(, 2).Resize(, 3).Copy _
Destination:=.Range("B" & i & ":D" & i)
End If
Next
End With
Set Sh1 = Nothing
Set Sh2= Nothing
Set Sh3 = Nothing

ここで、もし、最新データA列の番号と元データの番号を見て一致しないもの、元データにしかないものや最新データにしかないものがあったら、新規データとして、別シートに行ごと書き写したい場合はどのようにすれば良いのでしょうか？

No.1 ベストアンサー 回答者： ta123 回答日時： 2004/11/05 15:45

「このモジュールに追加するかたちで」という条件がある解釈しました。

最新データは全行見るが元データは全行見ていないことより
1.新規データに一旦、元データをすべてコピーする。
2.最新データと元データを比較して、
(a)最新データが元データにあった場合は新規データから削除
(b)最新データが元データになかった場合は最新データを新規データに追加する
という方法が思いつきました。
以下、サンプルコーディング。

Set Sh1 = Worksheets("元データ")
Set Sh2 = Worksheets("新規データ")
Set Sh3 = Worksheets("最新データ")

'↓追加*******************************************************************
'元データを新規データにコピー
With Sh1
.Select
Cells.Select
Selection.Copy
.Range("A1").Select
End With
With Sh2
.Select
.Range("A1").Select
ActiveSheet.Paste
.Range("A1").Select
End With
'↑***********************************************************************

With Sh3
For i = 5 To .Range("A65536").End(xlUp).Row
' N_D = .Range("E" & i).Value ←　修正
N_D = .Range("A" & i).Value
Set myR = Sh1.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _
MatchCase:=False)
If Not myR Is Nothing Then
' myR.Offset(, 2).Resize(, 3).Copy ←　修正
myR.Offset(, 1).Resize(, 3).Copy _
Destination:=.Range("B" & i & ":D" & i)

'↓追加*******************************************************************
' 新規データから最新データにもあるデータを削除
Set myR = Sh2.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _
MatchCase:=False)
newR = myR.Row
Sh2.Rows(newR).Delete

Else
' 新規データに元データに無い最新データを追加
addR_No = Sh2.Range("A65536").End(xlUp).Row + 1
.Range("A" & i & ":D" & i).Copy _
Destination:=Sh2.Range("A" & addR_No & ":D" & addR_No)
'↑***********************************************************************

End If
Next
End With

Set Sh1 = Nothing
Set Sh2 = Nothing
Set Sh3 = Nothing

この回答へのお礼

ご回答ありがとうございます。
頭がうまく働かなくて混乱中です。
作り上げるのに時間がかかりそうなのですが、とても参考になりました。
ありがとうございました。

お礼日時：2004/11/08 23:32