Excel(エクセル)2007のVBAです。

A列(1列)において、
「重複しているデータ」を削除して、A1~A列の最終行まで「空白セルをつくらずに」データを並べるVBAコード(ソース)を教えてほしいです。


具体的には、


【A列】
A1:犬
A2:猫
A3:猫
A4:犬
A5:犬
A6:ライオン

上記のようにデータがある場合に
コマンドボタン(CommandButton1_Click)実行で、

↓↓↓

【A列】
A1:犬
A2:猫
A3:ライオン
A4:
A5:
A6:

上のような結果になれば成功です。


説明させていただくと、

A列において「全く同じデータの入ったセル」が2つ以上ある場合、
2つ目以降をすべて削除して(セルごと削除して)、消えたセル分だけ、下のセルを上に詰めるようにしたいです。


一言でいうと
●重複分だけ削除 → 「A1~A列の最終行」までの間に、空白セル(データが存在しないセル)が1つもない状態
ということになります。


ここまでの条件を満たしてくれるコード(ソース)が分かった方、
どうかよろしくおねがいします。

また、書ける字数が足りなくなったのでこのページ下部の「この質問・回答へのコメント」欄に
【補足】を書かせていただきます。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/04/15 11:40:03
  • 終了:2011/04/15 14:26:15

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/04/15 13:03:25

ポイント230pt

質問はA列となっていましたが、他の列を処理することも考えている気がしたので

選択した範囲を処理する例を併せてサンプルも併せて書いてみました。

(複数セル選択した場合、そこを含むすべての列を順番に処理します。)

Option Explicit

'// 選択したセルを含む範囲の列を処理
'//------------------------------------------
Private Sub CommandButton1_Click()
    Dim selectArea As Range
    Set selectArea = Selection
    Dim r As Range
    For Each r In Intersect(Rows(1), selectArea.EntireColumn)
        MakeUniqueData r.Column '// 指定列を処理 1=A列
        selectArea.Select
    Next
End Sub

'// A列を処理する
'//------------------------------------------
Private Sub CommandButton2_Click()
    MakeUniqueData 1 '// 指定列を処理 1=A列
End Sub

'// 指定列のデータをユニークにする
'//------------------------------------------
Sub MakeUniqueData(dstColumn As Long)
    Dim objDictionary
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
'// 最終データ位置の取得
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, dstColumn).End(xlUp).Row
    
    
'// データの重複チェック
    Dim dataDuplicated As Boolean
    dataDuplicated = False
    
    Dim r As Long
    For r = 1 To lastRow
        If objDictionary.exists(Cells(r, dstColumn).Value) = True Then
            dataDuplicated = True
        Else
            objDictionary.Add Cells(r, dstColumn).Value, 1
        End If
    Next

'// 確認処理
    If dataDuplicated = True Then
        If MsgBox("重複分を削除しますか?", vbYesNo, "削除確認") = vbYes Then
            Range("A1").Offset(0, dstColumn - 1).Resize(objDictionary.Count) = Application.WorksheetFunction.Transpose(objDictionary.keys)
            Range("A1").Offset(objDictionary.Count, dstColumn - 1).Resize(lastRow - objDictionary.Count, 1).ClearContents
        End If
    Else
        MsgBox "重複データはありません!"
    End If
End Sub
id:egaosaiko

Mookさんへ

毎回お答えいただきありがとうございます。

すごい助かっております。

私の質問(要望したコード)内容に完璧な処理を確認させていただました。

感謝します!

さらに、応用の利く発展形まで考えていただき、その心遣いが嬉しいかぎりです。

複数列連続重複削除シビれましたね!!

思わず10行連続でやってみたりしちゃいました。

これは相当使えそうですね!

2011/04/15 14:14:51

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692011/04/15 12:32:20

ポイント200pt

先のコメントはコメント部分が実装されていませんでした。

Private Sub CommandButton1_Click()
    Dim i As Long
    Dim lastRow As Long
    Dim res As Object
    Dim f As Boolean
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = lastRow To 2 Step -1
        Set res = Range("A1:A" & i - 1).Find(what:=Cells(i, "A").Value, _
            LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
        If Not res Is Nothing Then
            If f Then
                Cells(i, "A").Delete
            Else
                If MsgBox("重複分を削除しますか?", vbYesNo + vbQuestion) = vbYes Then
                    Cells(i, "A").Delete
                    f = True
                Else
                    Exit Sub
                End If
            End If
        End If
    Next i
    
    If Not f Then
        MsgBox "重複データはありません!", vbExclamation
    End If
End Sub
id:egaosaiko

SALINGERさんへ

ご回答ありがとうございます。

そして、お手数かけて申し訳ありませんでした。

コードについてですが、

補足も含めて私の要望に忠実でした!

いろんな条件のデータで試させていただきましたが、

エラーもなくスムーズでした。

ありがたいです!

2011/04/15 13:43:05
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/04/15 13:03:25ここでベストアンサー

ポイント230pt

質問はA列となっていましたが、他の列を処理することも考えている気がしたので

選択した範囲を処理する例を併せてサンプルも併せて書いてみました。

(複数セル選択した場合、そこを含むすべての列を順番に処理します。)

Option Explicit

'// 選択したセルを含む範囲の列を処理
'//------------------------------------------
Private Sub CommandButton1_Click()
    Dim selectArea As Range
    Set selectArea = Selection
    Dim r As Range
    For Each r In Intersect(Rows(1), selectArea.EntireColumn)
        MakeUniqueData r.Column '// 指定列を処理 1=A列
        selectArea.Select
    Next
End Sub

'// A列を処理する
'//------------------------------------------
Private Sub CommandButton2_Click()
    MakeUniqueData 1 '// 指定列を処理 1=A列
End Sub

'// 指定列のデータをユニークにする
'//------------------------------------------
Sub MakeUniqueData(dstColumn As Long)
    Dim objDictionary
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
'// 最終データ位置の取得
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, dstColumn).End(xlUp).Row
    
    
'// データの重複チェック
    Dim dataDuplicated As Boolean
    dataDuplicated = False
    
    Dim r As Long
    For r = 1 To lastRow
        If objDictionary.exists(Cells(r, dstColumn).Value) = True Then
            dataDuplicated = True
        Else
            objDictionary.Add Cells(r, dstColumn).Value, 1
        End If
    Next

'// 確認処理
    If dataDuplicated = True Then
        If MsgBox("重複分を削除しますか?", vbYesNo, "削除確認") = vbYes Then
            Range("A1").Offset(0, dstColumn - 1).Resize(objDictionary.Count) = Application.WorksheetFunction.Transpose(objDictionary.keys)
            Range("A1").Offset(objDictionary.Count, dstColumn - 1).Resize(lastRow - objDictionary.Count, 1).ClearContents
        End If
    Else
        MsgBox "重複データはありません!"
    End If
End Sub
id:egaosaiko

Mookさんへ

毎回お答えいただきありがとうございます。

すごい助かっております。

私の質問(要望したコード)内容に完璧な処理を確認させていただました。

感謝します!

さらに、応用の利く発展形まで考えていただき、その心遣いが嬉しいかぎりです。

複数列連続重複削除シビれましたね!!

思わず10行連続でやってみたりしちゃいました。

これは相当使えそうですね!

2011/04/15 14:14:51

質問者が未読の回答一覧

 回答者回答受取ベストアンサー回答時間
1 SALINGER 3454 2392 969 2011-04-15 12:02:44
  • id:egaosaiko
    ※【補足です】

    補足①もし可能なら、次のような条件で「メッセージボックスを使った処理」にしていただけると、かなり助かります。
       3パターンになります。  

    ●(パターン1)
    コマンドボタン(CommandButton1_Click)実行
     ↓
    重複しているデータが1つもない場合、
    メッセージボックスが「重複データはありません!」と表示


    ●(パターン2)
    コマンドボタン(CommandButton1_Click)実行
     ↓
    全く同じデータが2つ以上ある場合のみ、
    メッセージボックスが「重複分を削除しますか?」と表示するので、
    そこで「はい」を選択
     ↓
    重複データを削除してから、A列(A1~)に表示


    ●(パターン3)
    コマンドボタン(CommandButton1_Click)実行
     ↓
    全く同じデータが2つ以上ある場合のみ、
    メッセージボックスが「重複分を削除しますか?」と表示するので、
    そこで「いいえ」を選択
     ↓
    メッセージボックスを閉じる



    補足②「半角と全角の区別」、「スペースの区別」をつけます。
      ↓
    (例)
    ●「2」と「2」は重複にはなりません。
    ●「ライオン」と「ライオン」は重複にはなりません。
    ●「浦島太郎」と「浦島 太郎」は重複にはなりません。
    ●「浦島太郎」と「浦島 太郎」は重複にはなりません。
    ●「浦島 太郎」と「浦島 太郎」は重複にはなりません。


    よろしくおねがいいたします。
  • id:SALINGER
    先に回答したものはコメントを見ないで回答してしまったので、
    オープンしなくていいです。
  • id:egaosaiko
    SALINGERさん

    こちらこそ、分かりにくい質問の仕方で申し訳ありません。
    最初の方で、「コメント欄に補足がありますので、そちらまで読んでいただけると嬉しいです。」
    ぐらい書くべきでした。
  • id:egaosaiko
    SALINGERさん Mookさん

    理想的なコード
    ありがとうございました。
    かなり満足しております。

    今回は質問の性質上、どうしてもご回答内容に差がつきにくい結果となったので、
    ややもすると今回の私と同じような疑問をもち、検索エンジンからこのページにたどり着くであろう訪問者に
    より多くの選択肢を与えるであろう2パターンのコードを示してくれた、Mookさんにベストアンサーを差し上げることにしました。


    いろいろと思うところあるかとは思いますが、
    どうかよろしくおねがいします。
  • id:SALINGER
    たくさんのポイントありがとうございます。
    質問自体はそんなに難しい質問ではなくて、少しVBAを勉強すれば自分で作れるレベルだと思います。
    こういう行毎にを削除するパターンっていうのは、下の行から調べて削除していくというのにさえ気をつければ後は基本的な関数だけで実現できるので、私の回答を参考にぜひチャレンジしてみてください。
  • id:egaosaiko
    SALINGERさんへ

    アドバイスありがとうございます。

    おっしゃる通り、基本的なことも分かっていないので
    少しずつでも勉強してみたいと思います。

    また見かけたら、
    どうかよろしくおねがいします。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません