人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルマクロで重複データをすべて自動削除することを教えてください。

あるシートがあります。
H列に英数字半角の顧客IDが入っています。(H1は見出しです)

★それらのIDで重複していたら、それらの行ごとすべて削除するというマクロをお願いしたいのです。


H
顧客ID
aaa
bbb
ccc
ddd
ccc
eee


↑の例でしたら、cccが重複していますので、cccが入っている行を2行まとめて削除して、
上につめていただきたいです。重複しているデータは1つに限らず、何個も重複していたり、
重複がまったくないときもあります。

行はどこまで続くかは不明ですので、H列の欄が空白になった時点でマクロを止めるようにしてください。


H列は変わることがありますので、”H”を入れておいていただけますでしょうか。

よろしくお願いいたします。


●質問者: naranara19
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● slow_learner
●100ポイント

xが列数、yが開始データの行数です。
比較元の行も削除するようにしています。

Sub hatena()
x = 1
y = 1
Do While Cells(y, x).Value <> ""
id1 = Cells(y, x).Value
z = y + 1
flag = 0
Do While Cells(z, x).Value <> ""
If Cells(y, x).Value = Cells(z, x).Value Then
Cells(z, x).Delete Shift:=xlUp
flag = 1
Else
z = z + 1
End If
Loop
If flag = 1 Then
Cells(y, x).Delete Shift:=xlUp
Else
y = y + 1
End If
Loop
End Sub


naranara19さんのコメント
ありがとうございます。指定が「行ごと」となっておりまして、どうもその指定の列の行しか削除されないようです。そうすると、隣のデータとずれてしまいまして、少し困るのです。迅速なご回答ありがとうございます。

slow_learnerさんのコメント
他の方の回答も付いていましたね。行削除に直したので、一応貼っておきます。 xとyの使い方はさっきと一緒ですが、いちいち書き換えるのも大変なので、 マクロ実行時点の選択セルの行と列を取得するようにしておきました。 Sub hatena() x = Selection.Column y = Selection.Row Do While Cells(y, x).Value <> "" id1 = Cells(y, x).Value z = y + 1 flag = 0 Do While Cells(z, x).Value <> "" If Cells(y, x).Value = Cells(z, x).Value Then Rows(z).Delete Shift:=xlUp flag = 1 Else z = z + 1 End If Loop If flag = 1 Then Rows(y).Delete Shift:=xlUp Else y = y + 1 End If Loop End Sub

naranara19さんのコメント
ありがとうございました!ご丁寧に感謝します。動作いたしました!何度もすみません!!

2 ● kseikaku
●10ポイント

マクロでないとダメですか?

重複がある列(質問だとH列)全体を選択した状態で、メニューの「データ」>「フィルタ」でフィルタをかけて、「データ」>「詳細設定」で詳細設定画面を開くと、下に「重複するレコードは無視する」のチェックボックスがあります。
こちらをチェックを入れると、重複するデータのあるレコードが非表示になるので、そのままつかうか、その状態で全体を選択して、別シートにコピーすれば、似たような状態になると思います。


naranara19さんのコメント
ありがとうございます。その方法は知っているのですが、自動処理したいため、お願いしております。回答ありがとうございます。

3 ● Mook
●100ポイント ベストアンサー

行全体を消すということなので、下記でどうでしょうか。
重なっているデータの行をすべて消すという説明なので、
H列がAA,BB,CC,AA,BB,AA だと CC の行だけになる処理です。

Option Explicit

Const ID_ROW = "H"
Sub DeleteDuplicatedRows()
 Dim objDic
 Set objDic = CreateObject("Scripting.Dictionary")

 Dim r As Long
 r = 2
 Do While Cells(r, ID_ROW).Value <> ""
 objDic(Cells(r, ID_ROW).Value) = objDic(Cells(r, ID_ROW).Value) + 1
 r = r + 1
 Loop
 
 Application.ScreenUpdating = False
 Do While r >= 2
 If objDic(Cells(r, ID_ROW).Value) >= 2 Then Cells(r, ID_ROW).EntireRow.Delete
 r = r - 1
 Loop
 Application.ScreenUpdating = True
End Sub

Mookさんのコメント
セルの含まれる行を指定する場合は、EntireRow プロパティを使用します。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ