エクセル 同じ文字を自動消去

質問

エクセルのメールアドレス一覧表があるのですが
同じメールアドレスが複数がある時、一つづつ消すのは
時間がかかり大変です。自動検索して自動消去する方法はないでしょうか？

回答No.10

kazuhiko5681 · ベストアンサー

こんばんわ。まだ、解決していないみたいですね。
ちょっと面倒かもしれませんが、Ａ１に適当な文字(アルファベットでも数字でも何でもよい)を１文字入れてエンターキーを押した時に行が削除できるようにマクロを組んでみました。１行目は、空白行として下さい。次のように操作します。

１．データの入力されているブックを開き、ＡＬＴ＋Ｆ１１キーを押してＶＢＥ画面を表示する。
２．画面左上にあるVBEProjectと書いてある下のSheet1をダブルクリックし、右側の白い部分に下記のコードをコピー・ペーストする。
３．再びＡＬＴ＋Ｆ１１キーを押してエクセルの画面にもどる
４.Ａ１に適当な文字を１文字入力するとマクロが動作する。

このマクロはＡ１とＡ２が同じ・Ｂ１とＢ２が同じ・Ｃ１とＣ２が同じであった時、２行目のデータを削除するようにしてあります。
もし、うまく動作しなかった場合には、VBAProjectの下にブックに挿入されているシートの枚数文(例えばシートが３枚あったとしたらShet1・Sheet2・Sheet3)コードエディタがあります。Sheet2・Sheet3もそれぞれダブルクリックしてそれぞれのコードエディタに同じようにコードを貼り付けて実行してみて下さい。こちらでは確認済みなので多分今度は動作すると思います。
お手数をおかけいたしますが、よろしくお願いいたします。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim myCnt As Integer

If Target.Address = "$A$1" Then
Application.EnableEvents = False
myRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To myRow - 1
If Cells(i, 1).Value <> "" Then
For j = i + 1 To myRow
For k = 1 To 3
If Cells(i, k).Value = Cells(j, k).Value Then
myCnt = myCnt + 1
If myCnt = 3 Then
Rows(j & ":" & j).ClearContents
End If
End If
Next k
myCnt = 0
Next j
End If
Next i

Do
myRow = Cells(Rows.Count, 1).End(xlUp).Row
If Cells(myRow, 1).End(xlUp).Row = 1 Then Exit Do
For i = 2 To myRow
If Cells(i, 1).Value = "" Then Rows(i & ":" & i).Delete
Next i
Loop
Application.EnableEvents = True
End If

End Sub

前回アクセスキーを使ってマクロを実行させようとしましたが、うまく動かなかったので、コマンドボタンで実行させる方法もご紹介しておきます。この方法を実行するには、次のように操作して下さい。

１.データが入力されているシートを開く。
２.メニューバーにマウスポインターを合わせて右クリック
３.出てきたプルダウンメニューのVisualBasicをクリック
４.出てきたツールバーのかなづちとスパナのマーク(コントロールツールボックス)をクリック
５.出てきたツールバーの一番右端の上から２番目(コマンドボタン)をクリックし、配置したい位置にマウスポインターを合わせクリックする。
６.配置されたコマンドボタンをダブルクリックするとＶＢＥ画面になり、コードエディターに自動的に
Private Sub CommandButton1_Click()
　　ここに下のコードをコピー・ペーストする。
End Sub
と表示される。

Dim myRow As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim myCnt As Integer

myRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To myRow - 1
If Cells(i, 1).Value <> "" Then
For j = i + 1 To myRow
For k = 1 To 3
If Cells(i, k).Value = Cells(j, k).Value Then
myCnt = myCnt + 1
If myCnt = 3 Then
Rows(j & ":" & j).ClearContents
End If
End If
Next k
myCnt = 0
Next j
End If
Next i

Do
myRow = Cells(Rows.Count, 1).End(xlUp).Row
If Cells(myRow, 1).End(xlUp).Row = 1 Then Exit Do
For i = 2 To myRow
If Cells(i, 1).Value = "" Then Rows(i & ":" & i).Delete
Next i
Loop

もし、変更点・ご不明な点がございましたらご遠慮なくお知らせ下さい。

補足

本当にありがとうございます
試してみます　また結果報告しますので
その時はどうぞよろしくお願い致します