重複データをなくすには?

Question 47.1 Excel VBA Borad (掲示板)より Previous Next
重複をなくすためのVBAで教えていただきたい事が有ります。
一つは重複をなくすために一方の内容を消去するように設定したいのですが、削除していくために変数の範囲が変わってしまいます。それを変えないようにするにはどうしたら良いかということと、

もう一つは処理したシートにもう一度処理をしてしまうと、内容がすべて消えてしまう結果にならないようにしたいのですが、どうしたら良いでしょうか。
と書いて何が言いたいか伝わらないですね。。。すいません。 マクロは上記のとおりです。
Sub 重複をなくす()
Dim a, b, i
    For i = 1 To 20
        With Worksheets("sheet1").Cells(i, 2)
            b = Worksheets("sheet1").Cells(i, 2)
            Set a = .Find(b, lookat:=xlWhole)
            If Not a Is Nothing Then
                a.Activate
                ActiveCell.EntireRow.Select
                Selection.Delete
            End If
        End With
    Next i
End Sub
実は上の処理をした後で別のシートと比較し、同じデータを新しいシートにかき出すというVBAを頼まれたのですが、一つづつ切りとって考えているために、上記のような質問になりました。
なお、一応 Cell(i,2)のデータのみで、ソートしてもOKです。ソートして 3つ以上ある場合でも、必ず一つを残して消去できるものでしょうか?
Answer   2001.7.17 うな
Cells(i, 2) のデータ以外のデータ [Cells(i, 1),Cells(i, 3)...] も同様であるなら、 「フィルタオプション」で重複しないデータを生成する事ができますが、Cells(i, 2) だけのため使うことができません。
ソート(並び替え[A to Z])をしてもOKということですから、Findメソッドは使いませんでした。

あくまでサンプルなので、ご期待通りの動作になるかは不明ですが、試してみてください。
'------------------------------------------------------------------------------
Sub test()
    Dim ws              As Worksheet    ' シート
    Dim i               As Long         ' ループカウンタ
    Dim rngTarget       As Range        ' ターゲットRANGE
    Dim strChangeValue As String        ' 項目変更値
    Const lngTargetCol As Long = 1      ' 対象列

    ' シートセット
    Set ws = ActiveSheet
    ' SORT(並び替え)
    Set rngTarget = ws.Cells(1, lngTargetCol)
    Call rngTarget.Sort(Key1:=rngTarget, Order1:=xlAscending, Header:=xlGuess)
    ' 行ごとの処理
    Do
        i = i + 1
        If IsEmpty(ws.Cells(i, lngTargetCol)) Then Exit Do
        If i = 1 Then
            ' 最初の処理
            strChangeValue = ws.Cells(i, lngTargetCol)
        Else
            If strChangeValue = ws.Cells(i, lngTargetCol) Then
                ' 項目が重複している場合、行の削除
                ws.Rows(i & ":" & i).Delete Shift:=xlUp
                ' 削除した行だけカウントダウン
                i = i - 1
            Else
                ' 項目名が変わった場合、項目変更値に格納
                strChangeValue = ws.Cells(i, lngTargetCol)
            End If
        End If
    Loop
End Sub
'------------------------------------------------------------------------------

 

Excel VBA Macro