重複した項目を削除するマクロ

質問

エクセルで同じID番号を持つ項目が2行あったとして、1行だけ残してもう1行は削除する、といったマクロを教えてください。
例：
A列 B列 C列 D列
1 氏名　　ID=150　　住所　　備考
2　氏名　　ID=150　　住所　　備考
3　氏名　　ID=10　　 住所　　備考
4　氏名　　ID=10　　 住所　　備考
5　氏名　　ID=10　　 住所　　備考
　　　↓↓↓↓↓↓↓↓↓↓↓↓
A列 B列 C列 D列
1 氏名　　ID=150　　住所　　備考
2　氏名　　ID=10　　 住所　　備考

という表にしたいのです。
アドバイスよろしくお願いします。

回答No.10

Wendy02 · ベストアンサー

こんにちは。

アドバイスとしては、もしも、除外条件をつけるなら、単に、D列ではなくて、他の部分もあわせてすればよいので、具体的に、これとこれを合わさったら、削除は出来ないというような条件が出れば考えてみます。人が合理的に判断できるものなら、その判断は、VBAでも可能です。

たぶん、ここでお聞きになっているのは、本当に回数が多く面倒だからでしょうね。ある程度の試行錯誤はやむをえない、と思ってくださいね。がんばって後々改編の必要のないものを作ったほうがよいですね。

私の誤解があったかもしれません。私がこだわったのは、要するに、「会社名の入力のブレ」というものです。一般的には、会社名に対してよりも、IDのほうが確実だと思ったからです。

それは、私の昔の経験で、会社名というのは、時々、その入力のブレがあって、うまく統合できなかったことがあったからです。社名変更もそのひとつの理由ですが、納品書を元にすると、ブレてしまうのです。それがもしコンピュータ出力で、「ブレがない」としたら、会社名でしてしまえばよいです。（もちろん、元はExcelではなく、データベースからのCSV出力です。）

>F列の先頭の結合を解除するコードを追加したら、うまくF列の会社名の重複を検索削除できました。

結合は、そのままでも可能な気がします。ただし、横の結合で、縦の結合の時は、ちょっと事情が変わります。それと、データは、F列の結合セルに値があるのではなくて、あくまでも、「F列（結合セルの左端の列が、基点になる）」にあるのですから、結合自体は、その中では関係ありません。一度、試してみてください。

これで、F列で可能です。

修正前 Set SrchCol = Range("D1:D" & LastRow)　
　　　　　　　　　　　 ↓
後　 　Set SrchCol = Range("F1:F" & LastRow)　
　　と
修正前 If WorksheetFunction.CountIf(SrchCol, Cells(i, 4).Value) > 1
　　　　　　　　 ↓
後　　 If WorksheetFunction.CountIf(SrchCol, Cells(i, 6).Value) > 1

もう少し、我慢して情報を送り続けてくれたら、こちらも、いろいろ考えてみたいと思います。

お礼

ありがとうございました。
書き込んでいただいたものでうまく動いているので、暫くはこれで運用してみることにします。

回答No.9

Wendy02

こんにちは。

>実は、D列（数字）をキーに出来ない理由があります。
>同じD列に、消したくない別のデータが入っています。
>レイアウトが、一般的なエクセル表のイメージではないため、苦労しております。

おっしゃっている意味が良く分からないのですが、一体、何に対して重複した項目を削除するか、という根本的な問題を解決していらっしゃらないのではありませんか？

D列に消したくないデータとは言っても、重複しているものを削除するのですから、IDならIDでも構わないけれども、その部分に違ったデータが入っていること自体は論外です。しかし、仮に論外だとしても、IDとしてふさわしくないデータの場合は、

If WorksheetFunction.CountIf(SrchCol, Cells(i, 4).Value) > 1 Then　'D列
' ** この部分に、除外条件を持ってくることは可能です。
　　　　Rows(i).Delete
End If

例えば、5桁以上は違うとか、IDは、必ず、4桁であるとか、そうした区分けをするだけの条件はあるはずです。なお、文字データで、その重複を調べるのは、「揺らぎ」があって、確実性が下がるような気がします。

お礼

アドバイスありがとうございます。
D列は、ID番号（3桁）という決まった項目ではなく、商品の単価（4桁）も入っています。
扱っているエクセル表はシステムからエクスポートしてきたもので、きちんとした表にはなっていないものなのですが、必ず決まった列に同じ項目（内容）が入ってきます。
ID番号は今のところは3桁なので、4桁は除外するといった条件を入れるといいのですね。

前回アドバイスを頂いたコードの上に、F列の先頭の結合を解除するコードを追加したら、うまくF列の会社名の重複を検索削除できました。
が、確実性が下がるといわれるとそう思いますので、今回書いていただいたコードを追加して試してみます。

回答No.8

Wendy02

こんにちは。#7で書いた者です。

それは、単純な内容ではないようですね。
全体の内容が分からないので、もしかしたら無理かなって思いますが……。

>8行目　　　　　　　\1000 \2000 \3000(金額のデータが行が変わってO列～V列に入っている）

この８行目以降がどういう作用をするのか、見当が付きませんが、検索列の対象は、あくまでも、D列にしました。

Sub DeleteOnDoubled()
Dim LastRow As Long
Dim SrchCol As Range
Dim i As Long
　 LastRow = Range("D65536").End(xlUp).Row
　 Set SrchCol = Range("D1:D" & LastRow)

　 Application.ScreenUpdating = False
　 For i = LastRow To 2 Step -1
　　 If WorksheetFunction.CountIf(SrchCol, Cells(i, 4).Value) > 1 Then　'D列
　　　　Rows(i).Delete
　　 End If
　 Next i
　 Application.ScreenUpdating = True

　 Set SrchCol = Nothing
End Sub

お礼

早速試したらうまくいきました！ありがとうございます。
が・・・、実は、D列（数字）をキーに出来ない理由があります。
同じD列に、消したくない別のデータが入っています。
レイアウトが、一般的なエクセル表のイメージではないため、苦労しております。（同じ列に同じ項目のデータが入っているわけではない）

そうすると、F列（F～P列まで結合されている）の会社名をキーにして動かしたいなと思っていのですが・・・。
結合を解除してから、考えていただいたコードをDからF列に直すのが一番早いのかもしれませんね。

回答No.7

Wendy02

こんにちは。

実際のデータは、

　　A列　　 B列　　　 C列 　　D列
1 氏名　　ID=150　　住所　　備考

と一行目から始まるものではないからでしょうね。それでエラーは発生します。
私は、せっかくpamsdさんが手を付けられたものですから、今のところ、コードを書くつもりはありませんが、実際に、一番近いサンプルを挙げられたら、また、別のアドバイスも可能かと思います。

お礼

書き込みありがとうございます。自分でアレンジできるかと思い巻いたが、実力不足ですみません。
実際のデータですが、セルが結合された状態のところを検索重複削除する必要があります。そして、上の5行目くらいまでは、タイトルや日付などのデータが入っていて、それはそのままにしておきたいのです。
A列～C列（結合）　D列～E列（結合）　　F列～P列（結合）　がそれぞれ結合されています。そして、下記の内容がその結合された列に入力されている状態です。
6行目 　番号(A列-C列）　　150(D列-E列)　あいう株式会社(F列-P列)
7行目 　番号(A列-C列）　　150(D列-E列)　あいう株式会社(F列-P列)
8行目　　　　　　　\1000 \2000 \3000(金額のデータが行が変わってO列～V列に入っている）
ここに書くと分かりづらくなってしまいまして、申し訳ないのですが、
よろしくお願いします。

回答No.6

pamsd

すみません、いくつかサンプルではなく

質問にある

A列 B列 C列 D列
1 氏名　　ID=150　　住所　　備考
2　氏名　　ID=150　　住所　　備考
3　氏名　　ID=10　　 住所　　備考
4　氏名　　ID=10　　 住所　　備考
5　氏名　　ID=10　　 住所　　備考
で まず 動作の確認をとったらいいでしょう。

これで 期待通りの結果になるならば、
質問の内容は 満たしていると考えられますが・・・。

お礼

おっしゃるとおりです。
例題で試してみたらうまく動きました！
ありがとうございました。これをアレンジして動かしてみます。

補足

早速、アレンジ後、実データで試しましたが、
c = Selection.Row　
で、デバックエラーが出ます。オーバーフローになってしまいます。
自分でも考えてみましたが、難しくて、もしすぐに原因が分かるようでしたらアドバイスいただければ助かります。
よろしくお願いします。

回答No.5

Wendy02

割り込み失礼します。

私は、設問の内容から判断して、実際のデータとの食い違いを予感して、回答の書き込みをチュウチョしてしまいました。しかし、今回、予想外の結果ですので、書き込みすることにしました。

#1 さんのコードは、こちらで何度もスタイルを変えて試してみましたが、列位置が変わらない限りは、たとえ、上下に位置が変わっても問題ないと思います。

それを、回答者さんにその結果だけをおっしゃっても、#3,4 でかなり困ってらっしゃるようです。私も可能性を考えてみましたが、B列のセルの比較という条件がなされないということしか、その可能性はありません。

質問者さんは、もう一度、質問で出された設問内容と、実際のデータの違いを検証して、一体、実際のデータとどう違うのか提示していただかないと、これは解決しないように思います。

お礼

アドバイスありがとうございます。
いくつかいただいたサンプルを全部やってみようと思っていますので、結果がどうなったかを書き込むのに時間がかかってしまっています。
もう少し検証してみてまた後日結果を書き込みますので、よろしくお願いします。

回答No.4

pamsd

ん・・

No3の回答は 間違いでした。
B列は B列でいいのか・・・。

とりえあず訂正。

B列が 重複しないように しているのですが
B列以外も 考慮するのでしょうか？

お礼

いえ、B列をキーとして重複しているデータを探して、複数あるレコードを1件だけ残すということですので、「B列が重複しないように」というのは間違いではない？と思います。
私が例で載せたものと実際のものがかなり違いますので、アレンジに時間がかかっています。
もう少し検証してみようと思います。

回答No.3

pamsd

あ、わかりました。
B列が IDかと思ってましたが C列なんですね。

Range("B1").Select
を
Range("C1").Select
に変えて実行してみてください。

回答No.2

imogasi

（１）Sheet1を原本として、Ｂ列でソートする。
この順序を保ちたい場合は余白１列に、ソート前に連番を振っておく。
（２）重複なし状態に書き出し
行削除するやり方もありますが
（１）もとのシートが残る
（２）たぶん処理が早い
（３）ロジックが単純で、間違いが少ない。
のでお勧め。
Sub test02()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
'---
K = 2 'Ｓｈｅｅｔ２書き出し先頭行
d = sh1.Range("a65536").End(xlUp).Row 'Ｓｈｅｅｔ１最下行
Application.ScreenUpdating = False
'---
m = ""
'---第２行から最下行まで繰り返し
For r = 2 To d
If sh1.Cells(r, "B") = m Then
'直前と同じなら何もしない
Else
'直前と変わったら
'セルのデータを移す
For c = 1 To 5
sh2.Cells(K, c) = sh1.Cells(r, c)
Next c
K = K + 1
m = sh1.Cells(r, "B")
End If
Next r
Application.ScreenUpdating = True
End Sub
（３）元の順序を保ちたい場合はＳｈｅｅｔ２の連番列でソート
Ｓｈｅｅｔ２の見出しやソートもＶＢＡでできますが省略。

お礼

書き込みありがとうございます。
アドバイスいただいたものを全部試してみるつもりでおりますので、お礼と結果が遅くなってしまっており申し訳ございません。
また、実際imogasiさんのも試したのですが、私が例で書いたものと実際のものがだいぶ違っているので、アレンジするのに四苦八苦しており時間がかかっております。
現時点では、残したいデータも削除されてしまい、うまく動いていない状態です。

回答No.1

pamsd

Sub Macro1()
'
' Macro1 Macro
'
'
start:
Range("B1").Select
Selection.End(xlDown).Select

c = Selection.Row
start2:
If c = 1 Then GoTo ending
b = Cells(c, 2)
f = 0
For a = c - 1 To 1 Step -1
If Cells(a, 2) = b Then Rows(a & ":" & a).Delete Shift:=xlUp: f = 1
Next a
If f = 0 Then c = c - 1: GoTo start2
GoTo start
ending:

End Sub

これでいけるでしょう。

お礼

ご回答ありがとうございます。
試してみましたが、重複データがあった場合は、全部消えてしまいます。（例えば、2行同じものがあれば、2行ともなくなる）
1つだけは残したいのですが、可能でしょうか？