エクセルで重複するセルを削除したい

質問

エクセル２０００で同じ内容のセルが複数あったとき、ひとつだけを残し他を削除する方法を教えてください。
ただし少し条件があります。

データーは５列１００行位からなっています。
A列にある重複したデーターのセルを削除したいのですが、A列は同一なのですがB列は異なっています。B列に数字が入っているセルとうでないセルがあるのですが、数字が入っているものを残したいのです。

具体例は次のとおりです。
A列に 「ホンダCIVIC」 B列　「-」と書かれた行と
A列に 「ホンダCIVIC」 B列　「2」と書かれた行、
A列に 「ホンダCIVIC」 B列　「5」と書かれた行、
のA列だけを見ると重複した３行が有ったとします。
B列に「5」または「2」の入った行ひとつだけ残し、他を削除したいのです。
何かよい方法があればお教えください。よろしくお願いします。

回答No.4

imogasi · ベストアンサー

済みません、直ぐ気がついたのですが、Ｓｈｅｅｔ２へＳｈｅｅｔ１のセルから移すところ
For k = 1 To 4
sheet2.Cells(j, k) = sheet1.Cells(i, k)
Next k
の真中行の右辺を
sheet2.Cells(j, k) = RTRim(sheet1.Cells(i, k))
として見てください。
For K=1 ・・が３箇所あるので、３箇所修正してください。これが原因ではないでしょうか。
比較して見るときだけＲＴｒｉｍしていました。セルへセットする部分もＲＴｒｉｍしましょう。
それとＲＴｒｉｍで無くＴｒｉｍで統一してみて、どちらが良いか、結果を見てください。

お礼

何度もご迷惑をおかけし申し訳ありません。
#6さんの回答をきっかけに原因がわかってきました。
問題は私のデーターにあるようです。

webファイルで出力しソースを確認したところ、半角スペースが特殊文字である で記入されていました。これが半角スペースが除去できなかった原因であると思われます。
ご迷惑をおかけし申し訳ありませんでした。

今回教えていただいたことで改めてVBAがいろいろできることを認識しました。
もしよろしければご推奨のサイトとか書籍があればお教えいただけないでしょうか。
よろしくお願いします。

補足

たびたびで申し訳ありません。
ご指摘部分を修正したのですが、変化はありませんでした。
RTrim Trimともに同じです。
まだ何か有りましたらよろしくお願いいたします。
最終的には次のようになっています。

Sub test01()
Dim sheet1, sheet2 As Worksheet
Set sheet1 = Worksheets("sheet2")
Set sheet2 = Worksheets("sheet3")
'-----ソート
sheet1.Range("A3:D1500").Sort Key1:=sheet1.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
Key2:=sheet1.Range("B1"), Order2:=xlAscending, Header:=xlNo
'-----
d = sheet1.Range("a1").CurrentRegion.Rows.Count
'--------初期設定
m = RTrim(sheet1.Cells(1, 1))
j = 1
For k = 1 To 4
sheet2.Cells(j, k) = RTrim(sheet1.Cells(1, k))
Next k
'--------前行とダブり判定
For i = 2 To d
If m = RTrim(sheet1.Cells(i, "A")) Then
b = sheet1.Cells(i, "B")
If IsNumeric(b) = True Then
For k = 1 To 4
sheet2.Cells(j, k) = RTrim(sheet1.Cells(i, k))
Next k
End If
Else
j = j + 1
m = RTrim(sheet1.Cells(i, "A"))
For k = 1 To 4
sheet2.Cells(j, k) = RTrim(sheet1.Cells(i, k))
Next k
End If
Next i
End Sub

回答No.6

happypoint

#5です。

補足します。
検索条件を入力後、最後に「すべて置換」のボタンを押してください。

お礼

ご回答ありがとうございます。
少しずつ原因がわかってきました。
問題は私のデーターにあるようです。

ご指摘の方法で取れるはずでやってみたのですが、取れません。
おかしいと思い、webファイルで出力しソースを確認したところ、半角スペースが特殊文字である で記入されていました。これが半角スペースが除去できなかった原因であると思われます。
どうもありがとうございました。

回答No.5

happypoint

こんにちは。

半角のスペースを除去するのでしたら、A列を選択状態にした後、「編集」→「置換」で、いかがでしょうか。

「検索する文字列」を、「 」(半角スペース)
「置換後の文字列」を、「」（なにも入力しない）

で、半角スペースをすべて取り除けます。

回答No.3

imogasi

>、文字のあとに半角スペースが１個ついていたり２個ついていたりばらばらの状態でした。
RTrim（右側のスペースをのぞく）と言うＶＢの関数があります。それを使うと、下記変更だけで、追加行コーディング不要です。
m = sheet1.Cells(1, 1) －－＞m = RTrim(sheet1.Cells(1, 1))
m = sheet1.Cells(1, 1) -->m = RTrim(sheet1.Cells(1, 1))
If m = sheet1.Cells(i, "A") Then -->
If m = RTrim(sheet1.Cells(i, "A")) Then
m = sheet1.Cells(i, "A") -->
m = RTrim(sheet1.Cells(i, "A"))
と変更してやって見てください。
場合によればＢ列データもＴｒｉｍする必要があるかもしれません。Ｔｒｉｍは前後両方のスペースを取り除くので
こちらがベターかも知れません。

補足

早速連絡いただきありがとうございます。
教えていただいた変更を加え実行してみたのですが、何も変化はありません。
A列の半角スペースも前と同様２個だっり３個だったりバラバラのままです。
次のような形でマクロを実行しているのですが、どこがおかしいのでしょうか。
たびたびで申し訳ありませんがよろしくお願いいたします。

Sub test01()
Dim sheet1, sheet2 As Worksheet
Set sheet1 = Worksheets("sheet2")
Set sheet2 = Worksheets("sheet3")
'-----ソート
sheet1.Range("A1:D1500").Sort Key1:=sheet1.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
Key2:=sheet1.Range("B1"), Order2:=xlAscending, Header:=xlNo
'-----
d = sheet1.Range("a1").CurrentRegion.Rows.Count
'--------初期設定
m = RTrim(sheet1.Cells(1, 1))
j = 1
For k = 1 To 4
sheet2.Cells(j, k) = sheet1.Cells(1, k)
Next k
'--------前行とダブり判定
For i = 2 To d
If m = RTrim(sheet1.Cells(i, "A")) Then
b = sheet1.Cells(i, "B")
If IsNumeric(b) = True Then
For k = 1 To 4
sheet2.Cells(j, k) = sheet1.Cells(i, k)
Next k
End If
Else
j = j + 1
m = RTrim(sheet1.Cells(i, "A"))
For k = 1 To 4
sheet2.Cells(j, k) = sheet1.Cells(i, k)
Next k
End If
Next i
End Sub

回答No.2

imogasi

この類のものは関数式では無理でしょう。
へたくそなＶＢＡでやって見ました。ただし定石です。
少数例でしかテストをやってないので、よろしく。
ワークシート画面でＡＬＴキーを押しながらＦ１１キーをおす。更にＡＬＴキーを押しながらＩ（挿入）更にＭ（標準モジュール）の画面に下記を貼りつけて実行する。
Ｓｈｅｅｔ２にデータがあり、Ｓｈｅｅｔ３に望みのものを出す。
Sub test01()
Dim sheet1, sheet2 As Worksheet
Set sheet1 = Worksheets("sheet2")
Set sheet2 = Worksheets("sheet3")
'-----ソート
sheet1.Range("A3:B15").Sort Key1:=sheet1.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
Key2:=sheet1.Range("B1"), Order2:=xlAscending, Header:=xlNo
'-----
d = sheet1.Range("a1").CurrentRegion.Rows.Count
'--------初期設定
m = sheet1.Cells(1, 1)
j = 1
For k = 1 To 9
sheet2.Cells(j, k) = sheet1.Cells(1, k)
Next k
'--------前行とダブり判定
For i = 2 To d
If m = sheet1.Cells(i, "A") Then
b = sheet1.Cells(i, "B")
If IsNumeric(b) = True Then
For k = 1 To 9
sheet2.Cells(j, k) = sheet1.Cells(i, k)
Next k
End If
Else
j = j + 1
m = sheet1.Cells(i, "A")
For k = 1 To 9
sheet2.Cells(j, k) = sheet1.Cells(i, k)
Next k
End If
Next i
End Sub
（１）シート名は本番に合わせて、
Set sheet1 = Worksheets("sheet2")
Set sheet2 = Worksheets("sheet3")
の（）内を変えてください。
（２）３箇所あるFor k = 1 To 9の９に付いて、
シートのデータのある列をＩ列＝９までとしていますが、Ｇ列なら７、ｋ列まであるなら１１と変えてください。
（３）データは第１行目から始まっているものとしています。

お礼

ありがとうございます。できました！！！
しかし残念ながら私のデーターに不備があり期待した結果は得られませんでした。

頂いたマクロを実行したところ、Ａ列が一見同じであるにもかかわらず、削除できていないものが多数見つかりました。
元のデーターを見直したところＡ列が一見同じに見えるのですが、文字のあとに半角スペースが１個ついていたり２個ついていたりばらばらの状態でした。

もしできれば、Ａ列の半角スペースを除去するマクロなどあれば、独立したマクロとしてお教えいただけるとありがたいのですが。

回答No.1

arukamun

こんにちは

-と2と5が残った場合、どれを残すかは確実に決まっていないのでしょうか？

まず、ソートしましょう。
[データ]→[並べ替え]
列A
列B
でソートします。
C2セルに
=IF(AND(A1=A2,B1=B2),"重複","")
として、C3セルよりも下にもコピーします。
重複している行に重複と表示されます。
検索とかで、重複を検索して、その行を削除して行けば良いと思います。

補足

早速回答いただきありがとうございます。
残すのは数字が入っていればどれでもOKです。

書き忘れがあり申し訳ないのですが、このようなデーターが入ったページが３００ほど有ります。
できれば機械的に削除できる方法があればありがたいのですが。
よろしくお願いします。