Excel VBAを使った重複行の抜き出しについて教えてください

以下のような2シートから、重複する「商品番号」のあるsheet1の行を抜き出して、別シートに書き出したいと思っております。

sheet1
　｜　　A　　 ｜　 B　　　｜　C
-＋--------＋-------＋-----
1｜　　　 　　｜　　　　　　｜
-＋--------＋------＋--------
2｜商品番号｜商品名｜責任者
-＋--------＋------＋--------
3｜　 123456｜　 ガム｜山田太郎
-＋--------＋------＋--------
4｜ 2345678｜　チョコ｜田中花子
・・・

sheet2
　｜　　A　　 ｜　 B　　　｜　C
-＋--------＋-------＋-----
1｜　　　　　　｜　　　　　｜
-＋--------＋------＋--------
2｜商品番号｜商品名｜責任者
-＋--------＋------＋--------
3｜ 3987624｜　　　　　｜
-＋--------＋------＋--------
4｜ 193678｜　　　　　　｜
・・・

そこでVBAを作成したのですが、例えば商品番号「222011001」の行を抜き出したいのに、「22011001」の行も一緒に抜き出してしまいます。
どこがいけないのか、教えて頂けないでしょうか。
作成したVBAは以下の通りです。
VBA初心者で本を見ながら作ったため、大変見にくくなっているかと思います。申し訳ありませんが、どなたかおわかりになる方がいらっしゃいましたら、どうぞ宜しくお願い致します。

Option Base 1
Option Explicit
Sub 重複データ抽出書き直し()
Dim シート(2) As Worksheet
Dim 比較列(2) As Integer
Dim 一致セル As Range
Dim 検索範囲 As Range
Dim i As Integer

Set シート(1) = Sheets("sheet1")
Set シート(2) = Sheets("sheet2")
比較列(1) = 1: 比較列(2) = 1

シート(2).Activate
ActiveCell.CurrentRegion.Select
Selection.Offset(1, 比較列(2) - 1) _
.Resize(Selection.Rows.Count - 1, 1) _
.Select
Set 検索範囲 = Selection

Sheets.Add After:=Sheets(Sheets.Count)
シート(1).Activate
ActiveCell.CurrentRegion.Select
Selection.Resize(1).Copy
With Sheets(Sheets.Count).Range("A1")
If Application.Version >= 9 Then
.PasteSpecial 8
End If
.PasteSpecial
End With

For i = 2 To Selection.Rows.Count
Set 一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value)

If Not 一致セル Is Nothing Then
Selection.Offset(i - 1).Resize(1) _
.Copy Sheets(Sheets.Count) _
.Range("A65536").End(xlUp) _
.Offset(1)
End If
Next i

Sheets(Sheets.Count).Activate
End Sub

No.2 ベストアンサー 回答者： Wendy02 回答日時： 2007/05/14 13:33

こんにちは。

初心者とお書きになっていますが、他のプログラミング言語をおやりになっていますね。ただ、Excel VBAでは、使わないような方法がいくつもあります。VBAは、個人的なもので、なおかつ結果オーライですから、それに関しては、余計なお世話になってしまいますが、かなり入り組んだスキルが混じっている内容だと思います。特に、他人に見せる場合は、なるべく、オーソドックスなスタイルにしたほうがよいです。

個々の問題点ですが、

>例えば商品番号「222011001」の行を抜き出したいのに、「22011001」の行も一緒に抜き出してしまいます。

>一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value)

Find メソッドは、必要な引数は必ず入れてください。ワークシート（Excel）のメソッドは、VBAの概念とは違う仕様を持っていますので、使用する場合は気をつけたほうがよいです。デフォルトがデフォルトでないこともあります。

Set 一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value,)
　　　↓
Set 一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value, , , xlWhole)

もしも、Excel97を意識しているなら、いっそ、Application.Match(検索値,範囲,0)やCountIfを使ったほうがよいと思います。

それから、オブジェクトは、一般的には、配列にはしないで、Collectionにします。しかし、数が少ない場合は、個々に変数に代入します。

サンプルコード：
以下は、新しくペーストされるシートの重複も避けるように作られています。（以下の、Application.ワークシート関数は、古いスタイルの書き方です）

Sub getDoubledItems()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim NewSh As Worksheet
　　Dim ret As Integer
　　Dim i As Long
　　Dim col As Integer
　　
　　Set Sh1 = Worksheets("Sheet1")
　　Set Sh2 = Worksheets("Sheet2")
　　Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count))
　　
　　col = Sh1.Range("A2").CurrentRegion.Columns.Count
　　Sh1.Range("A2").Resize(, col).Copy NewSh.Range("A1")
　　'ここにセル幅の調整用のコードを入れます。
　　
　　Application.ScreenUpdating = False
　　With Sh1
　　　　For i = 3 To .Range("A65536").End(xlUp).Row
　　　　　　ret = Application.CountIf(Sh2.Columns(1), .Cells(i, 1).Value)
　　　　　　If ret > 0 Then
　　　　　　　　If Application.CountIf(NewSh.Columns(1), .Cells(i, 1).Value) = 0 Then
　　　　　　　　　　.Cells(i, 1).Resize(, col).Copy NewSh.Range("A65536").End(xlUp).Offset(1)
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　End With
　　Application.ScreenUpdating = True
　　Set Sh1 = Nothing: Set Sh2 = Nothing: Set NewSh = Nothing
End Sub

この回答へのお礼

ご回答頂き、ありがとうございました！
こんなに早くお返事を頂き恐縮です。

他のプログラミング言語に関してもちょっとかじった程度なので、Excelの本を読みながら頭の中で色々なものがごちゃまぜになって困っていた次第です・・・。
Excel97に対する記述も、あればいざという時便利なのかなという程度で、実際に使用しているのは2002なのです。欲張りすぎました（笑）。

findの部分について、Wendy02様に教えて頂いた通り追記しただけで、あっという間に解決してしまいました！まさに求めていたご返答です！急ぎで必要だったため、今回はそちらで解決させて頂きましたが、書いて頂いたサンプルコードも是非参考にさせて頂きたいと思っております。
本当にありがとうございました！

お礼日時：2007/05/15 10:43

No.1 回答者： pkh4989 回答日時： 2007/05/14 13:01

こんにちは。

まず、検索範囲の設定が間違いましたので、
以下のようにマクロを変えて見ました。如何でしょうか。

Option Explicit
Sub 重複データ抽出書き直し()
Dim Range1 As Range
Dim Range2 As Range
Dim mRow As Long
Dim c1 As Range
Dim c2 As Range
Dim wR As Long
Dim シート(3) As Worksheet

Sheets.Add After:=Sheets(Sheets.Count)
Set シート(3) = ActiveSheet
Set シート(1) = Sheets("sheet1")
Set シート(2) = Sheets("sheet2")
mRow = シート(1).Range("A" & Rows.Count).End(xlUp).Row
Set Range1 = シート(1).Range("A1:A" & mRow)
mRow = シート(2).Range("A" & Rows.Count).End(xlUp).Row
Set Range2 = シート(2).Range("A1:A" & mRow)

シート(3).Activate
wR = 0
For Each c1 In Range1
For Each c2 In Range2
If c2.Value = c1.Value Then
wR = wR + 1
シート(1).Rows(c1.Row).Copy
シート(3).Rows(wR).Select
シート(3).Paste
End If
Next
Next
End Sub

この回答へのお礼

ご回答頂き、ありがとうございました！
こんなに早くお返事を頂き恐縮です。

Excelのマクロに関して不慣れなもので、本を見ながらなんとなくわかったつもりで書いていたため、自分でも仕組みがよくわかっていない関数を多用していました・・。

Wendy02様が書いてくださったコードが「私の作成したコードに合わせて書いてくださったもの」ならば、pkh4989様が書いてくださったコードは「初心者の私にもわかりやすいスタイルで書いてくださったもの」なのではないかと感じております。どのような処理をしている部分なのかということが、コードを見ていてわかりやすかったです。
同じ処理をおこなうにも、色々な方法があるのだなということを実感いたしました。

今回は急ぎだったためWendy02様の回答を参考にさせて頂いたということで、ポイントをこのようにさせて頂きましたが、気持ちはお二人ともに20pt差し上げたい！と感謝いたしております。
最初にご回答頂きましたのに、申し訳ございません。
pkh4989様のコードも是非参考にさせていただき、今後の勉強に使用させて頂きます。
ありがとうございました！

お二人とも、またお力添え頂ければ幸いです。
今後ともどうぞ宜しくお願い申し上げます。

お礼日時：2007/05/15 11:16