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

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つもない状態
ということになります。


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

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

●質問者: ヘンリ
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:A1 A3 Excel VBA いただきます
○ 状態 :終了
└ 回答数 : 2/3件

▽最新の回答へ

1 ● SALINGER
●200ポイント

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

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
◎質問者からの返答

SALINGERさんへ

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

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

コードについてですが、

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

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

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

ありがたいです!


2 ● Mook
●230ポイント ベストアンサー

質問は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
◎質問者からの返答

Mookさんへ

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

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

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

感謝します!

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

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

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

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

関連質問


●質問をもっと探す●



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