エクセル 範囲内で重複しているデータを一意にしたい。セルは詰めないで空欄にしたい。

Question

前提・実現したいこと

範囲内で重複しているデータを一意にしたい。セルは詰めないで空欄にしたい。

おしえてgoo で以下のような質問があったのですが↓

VBAで重複するデータがあれば１個だけ残して他の重複セルを""（空白）にしたいのですが
範囲D5:D36に重複するデータがあれば、
１個だけ残して、他の重複セルに""（空白）を書き込みたいのですが
VBAではどう書けばよいでしょうか

D5:D36に下記のような空白を含むデータがあった時に
山田と書かれたセルは２つあるので、ひとつ残して、もうひとつは空白にしたいです
同じように高橋は３つあるので、ひとつ残して、あとの２つは空白にしたいです

山田
高橋
佐藤
空白
空白
鈴木
山田
空白
高橋
高橋

ベストアンサーはこれでした↓

詰めないで良いのですね？
この位ならば Dictionary 機能を使わなくてもどうにかなりそうだけど、行が増えた時に圧倒的に早くなりますので覚えておくと便利です。

---

Sub Sample()
Dim 辞書 As Object
Dim 行 As Long
Application.ScreenUpdating = False
Set 辞書 = CreateObject("Scripting.Dictionary")
For 行 = 5 To 36
If 辞書.Exists(Cells(行, 4).Text) Then
Cells(行, 4).ClearContents
Else
辞書.Add Cells(行, 4).Text, 行
End If
Next
Set 辞書 = Nothing
Application.ScreenUpdating = True
End Sub

---

###私の質問なんですが、 一列だけではなく範囲内の重複を検索して一意だけ残して他を空欄にしたい。
おそらくやりたいことは一致しているのですが質問は一列だけを検索しており、一列以上、たとえばA3セル~C8セルの範囲内で同じことをしたい場合はどのようにかきかえたらよいのでしょうか。
一意が残れば空白に変換する重複データはどこのでもかまいません。

空白 空白 空白
空白　空白 空白
山田　高橋 高橋
山田　佐藤 佐藤
鈴木　高橋 高橋
山田　鈴木 山田
高橋　佐藤 高橋
高橋　鈴木 高橋

ちなみにexcelの機能の重複の削除ですとセルを詰めてしまうのでやりたいことに使えないのです…。

補足情報（FW/ツールのバージョンなど）

excel2010

Answer 1

おそらくやりたいことは一致しているのですが質問は一列だけを検索しており、一列以上、たとえばA3セル~C8セルの範囲内で同じことをしたい場合はどのようにかきかえたらよいのでしょうか。
一意が残れば空白に変換する重複データはどこのでもかまいません。

現状のコードをなるべく活かすなら、下記のような感じでしょうか。（Dictionaryを活用）

Sub Sample2()
    Application.ScreenUpdating = False
    
    Dim 辞書 As Object
    Set 辞書 = CreateObject("Scripting.Dictionary")
    
    Dim セル範囲 As Range
    Set セル範囲 = Range("A3:C8")
    
    Dim セル As Range
    For Each セル In セル範囲
        If 辞書.Exists(セル.Text) Then
            セル.ClearContents
        Else
            辞書.Add セル.Text, 辞書.Count
        End If
    Next
    Set 辞書 = Nothing
    Application.ScreenUpdating = True
End Sub

ttyp03さんと被っちゃた(;^ω^)

Answer 2

ご提示いただいたコードを碌に見もせず回答してしまったので改めて回答します。
こちらはご提示のコードをベースに最小限の修正を行ったものです。
おそらくこれが求めているものと思われます。
ご確認ください。

Sub Sample()
    Dim 辞書 As Object
    Dim c As Range
    Application.ScreenUpdating = False
    Set 辞書 = CreateObject("Scripting.Dictionary")
    For Each c In Range("A1:C8")
        If 辞書.Exists(c.Text) Then
            c.ClearContents
        Else
            辞書.Add c.Text, c.Text
        End If
    Next
    Set 辞書 = Nothing
    Application.ScreenUpdating = True
End Sub

.

Comments

[kumiko]

すごく困っていたので助けていただいた全部の回答にベストといいたいところですが…
初めに回答いただき、質問に対しての回答も記載いただいたのでttyp03さんに。
ありがとうございます。vbaはずいぶん前にかじってふわーっとしか覚えていない状態でした。
皆様の回答をじっくり見直したいと思います。

Answer 3

難しく考えなくても、
手動でやるなら、どうやるかなぁ。。。っていう手順を考えたらいいと思います。

手動でやるなら、
左上から順番にセルを見て行く
1番目のセルの値を覚えておいて、同じ値があるかセル範囲を見て行く
同じ値があったら、空白に置換。
全部消えちゃったら、覚えている値をもう一回同じセルに書く
これを重複が無くなるまで繰り返せばいいのでは？

Sub test()
    Dim Rng As Range
    Dim c As Range
    Dim s As String
    
    Set Rng = Range("A3:C8")
    Do
        For Each c In Rng.SpecialCells(xlCellTypeConstants).Cells
            i = WorksheetFunction.CountIf(Rng, c.Value)
            If i > 1 Then
                s = c.Value
                Rng.Replace s, ""
                c.Value = s
                Exit For
            End If
        Next
    Loop Until i = 0
End Sub

ま、いくつか書き方や、別の考え方もあるとは思いますが、
基本は繰り返していくことになりますので、
Do～LoopやFor～Nextなどの構文を覚えましょう。

う～ん。ぱっと、瞬発的に書いちゃいましたが、
敢えて、CountIfで、数えてみないでも、
置換機能を無条件に繰り返した方が処理が速いかも？

Sub test2()
    Dim Rng As Range
    Dim c As Range
    Dim s As String

    Set Rng = Range("A3:C8")

    For Each c In Rng
        If IsEmpty(c.Value) = False Then
            s = c.Value
            Rng.Replace s, ""
            c.Value = s
        End If
    Next
End Sub

サンプルは最良のやり方ではないと思いますが、
高速化のコツはループの回数及びセルの読み書きの回数を減らすことです。
まずは希望の結果が出る方法を言葉にするところから始めてみてください。

Answer 4

検索の順序にもよりますね。
添付図の方式１（A列、B列、C列の順に検索）の場合
高橋はA7が残ります。
方式２（３行、４行、５行の順に検索）の場合、
高橋はB3が残ります。

どちらを希望されますか。

Answer 5

ベタな作りですが書いてみました。
コメントも書いておいたので解析してみてください。
ネストが深いのがちょっと自分的にはちょっとアレなんですが、基本的な流れはこうなるしかないかと思います。
対象範囲が巨大な場合パフォーマンスはよくないと思いますがまずはこれを回答とします。

Dim r As Range
Dim c As Range
Dim f As Range
Dim fn As Range

' 対象の範囲
Set r = Range("A1:C8")

' 対象の範囲の各セルでループ
For Each c In r
    ' セルが空白ではないとき
    If c <> "" Then
        ' 対象の範囲内の同じ値を検索
        Set f = r.Find(c, LookAt:=xlWhole)
        ' 見つかった
        If Not f Is Nothing Then
            ' 見つかった最初のセルを保持
            Set fn = f
            Do
                ' 次のセルを検索
                Set fn = r.FindNext(fn)
                ' 最初のセル位置に戻ったら抜ける
                If f.Row = fn.Row And f.Column = fn.Column Then Exit Do
                ' 見つかったセルの値を空白に置き換える
                fn = ""
                ' 無限ループ対策
                DoEvents
            Loop
        End If
    End If
Next