同一値が連続している列の削除

質問

エクセルで以下のようにA列にデータがあります。

sss
qqq
sss
sss
sss
qqq
fff
ttt
ttt
sss
sss

連続して同じデータが入っている列は最初の行だけのこしそれ以外は削除し以下のように表示したいと思っています。
sss
qqq
sss
qqq
fff
ttt
sss

あるサイトで連続データある場合は最初の行の値を表示して残りの同じ値のデータは背景色と同じにして見えないようにするマクロがありました、が私のやりたい事は不要な行を削除したいのです、
どなたかお知恵をお貸し下さい。

以下参照

＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃
Macro 同じ値が連続している時二番目以降のデータを見えなくする方法
(Excel97,Excel2000,Excel2002)
CSV ファイルや他のデータベースなどから、Excel のデータを作った場合 (データベース形式) 、
分類や区分などが連続して表示され、ごちゃごちゃと見にくいときがあります。

以下のマクロは、上の行と同じデータが入力されていた場合、下の行のデータを見えなくします。
削除するのではなく、背景色と同色にしますので、数式バーには元のデータが表示されます。

以下のコードを標準モジュールに貼り付けて、
該当するワークシートで、このマクロを実行してください。
対象は 「Ａ列」 です。

Sub SetFontColor()
'同じ値が連続している時二番目以降のデータを見えなくする。
'(Fontの色を背景色と同一にする)　A列のデータが無くなるまでループ
'2003/10/05 pPoy
Dim i As Integer
Dim myColor As Integer
Dim myC As String

myC = "A" 'A列指定
With ActiveSheet
i = 2 ' 2行目から開始
Do While .Cells(i, myC).Value <> ""
If .Cells(i - 1, myC).Value = .Cells(i, myC).Value Then
myColor = .Cells(i, myC).Interior.ColorIndex
If myColor = xlColorIndexNone Then
'背景色無
.Cells(i, myC).Font.ColorIndex = 2 '白

Else
'背景色
.Cells(i, myC).Font.ColorIndex = myColor
End If
End If
i = i + 1
Loop
End With
End Sub
≪注意≫
この作業は 「Ａ列」 が対象です。 必要に応じて列名を変更してください。

間に空白のセルがあると、そこで終了します。

実行後ワークシートは、無条件で上書きされます。

この作業は元に戻せません。　必ず最初に保存してから実行してください。
データを消去する方法は、こちら です。

＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃

回答No.1

hotosys · ベストアンサー

こんなのではどうでしょうか？
作業列を作ってます。
Sub sample()
Columns("B").Insert '作業列作成
With Range("B1:B" & Range("A" & Rows.Count).End(xlUp).Row) '作業範囲（Ｂ列の1行目からA列の最終データ行まで）
.Formula = "=IF(A1=A2,1,"""")" '連続データがある場合は1になる計算式
If WorksheetFunction.Count(.Value) > 0 Then '作業範囲に数値（連続データがある）場合は
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete '[編集][ジャンプ][セル選択]で[数式]の[数値]のセルを行に拡張してその行を削除
End If
End With
Columns("B").Delete '作業列削除
End Sub

お礼

おかげ様で、今回ご回答して頂いた2点のスクリプトでそれぞて希望通りの事が出来ました有難う御座います。

私が試したエクセルシートには2万以上の行があり、今回紹介して頂いた2通りのスクリプトで試しましたがこちらの方がスピードが速かったです。

回答No.2

fujillin

意味を正確に把握しているかどうか、わかんないけど…
こんな感じ？

Sub test()
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(r, 1).Value = Cells(r - 1, 1).Value Then Cells(r, 1).EntireRow.Delete
Next r
End Sub

お礼

有難う御座います
頂いたスクリプトで出来ました。