ｴｸｾﾙﾏｸﾛで重複ﾃﾞｰﾀをすべて自動削除することを教えてください｡あるｼｰﾄがあります｡ H列に英数字半角の顧客IDが入っています｡(H1は見出しです) ★それ…

人力検索はてな

ﾓﾊﾞｲﾙ版を表示しています｡PC版はこちら

ｴｸｾﾙﾏｸﾛで重複ﾃﾞｰﾀをすべて自動削除することを教えてください｡

あるｼｰﾄがあります｡
H列に英数字半角の顧客IDが入っています｡(H1は見出しです)

★それらのIDで重複していたら､それらの行ごとすべて削除するというﾏｸﾛをお願いしたいのです｡

例
H
顧客ID
aaa
bbb
ccc
ddd
ccc
eee

↑の例でしたら､cccが重複していますので､cccが入っている行を2行まとめて削除して､
上につめていただきたいです｡重複しているﾃﾞｰﾀは1つに限らず､何個も重複していたり､
重複がまったくないときもあります｡

行はどこまで続くかは不明ですので､H列の欄が空白になった時点でﾏｸﾛを止めるようにしてください｡

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

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

●質問者: ﾘｾｰﾙ京都買取
●ｶﾃｺﾞﾘ:ｺﾝﾋﾟｭｰﾀ
○ 状態 :終了
└ 回答数 : 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

ﾘｾｰﾙ京都買取さんのｺﾒﾝﾄ
ありがとうございます｡指定が｢行ごと｣となっておりまして､どうもその指定の列の行しか削除されないようです｡そうすると､隣のﾃﾞｰﾀとずれてしまいまして､少し困るのです｡迅速なご回答ありがとうございます｡

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

ﾘｾｰﾙ京都買取さんのｺﾒﾝﾄ
ありがとうございました！ご丁寧に感謝します｡動作いたしました！何度もすみません！！

▽2 ● kseikaku
●10ﾎﾟｲﾝﾄ

ﾏｸﾛでないとﾀﾞﾒですか？

重複がある列(質問だとH列)全体を選択した状態で､ﾒﾆｭｰの｢ﾃﾞｰﾀ｣＞｢ﾌｨﾙﾀ｣でﾌｨﾙﾀをかけて､｢ﾃﾞｰﾀ｣＞｢詳細設定｣で詳細設定画面を開くと､下に｢重複するﾚｺｰﾄﾞは無視する｣のﾁｪｯｸﾎﾞｯｸｽがあります｡
こちらをﾁｪｯｸを入れると､重複するﾃﾞｰﾀのあるﾚｺｰﾄﾞが非表示になるので､そのままつかうか､その状態で全体を選択して､別ｼｰﾄにｺﾋﾟｰすれば､似たような状態になると思います｡

ﾘｾｰﾙ京都買取さんのｺﾒﾝﾄ
ありがとうございます｡その方法は知っているのですが､自動処理したいため､お願いしております｡回答ありがとうございます｡

▽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 ﾌﾟﾛﾊﾟﾃｨを使用します｡