重複した値を一つ残す VBA

質問

重複した値を一つだけ残していきたいです。
たとえば　リンゴ　リンゴ　リンゴ　とあれば２つリンゴが消えて欲しいです
今のところ重複した値を消す方法しかわからず詰まっています。
なにとぞよろしくおねがいします　

Option Explicit

Sub test()
Dim i As Double
Dim x As Double
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Range("T3", Range("T" & Rows.Count).End(xlUp)).Sort Key1:=Range("T3"), Order1:=xlAscending, Header:=xlYes
For i = 3 To Cells(Rows.Count, 20).End(xlUp).Row
Range(Cells(i, "T"), Cells(i, "T")).RemoveDuplicates Columns:=Array(1), Header:=xlYes
Application.Calculate
Next
End Sub

回答No.2

imogasi · ベストアンサー

ここに質問をする前に、自分でいろいろ考えて、手段（ロジック）を考えること。
その後VBAコードでどう実現するか、自分のVBAの経験に照らしてやる。そのコードが判からなければ、したいロジックを文章で書いて質問するようにすべきだ。
＝＝＝
下記は
「ある行の１セルの値が、その列全体の中に、２件以上あれば１件分だけ書き出す」というロジックでやってみた。これならだれでも思いつくだろう。
まずA列でソートー＞コードは略
その次に
Sub test01()
i = 2
j = 2
lr = Worksheets("Sheet1").Range("A10000").End(xlUp).Row
MsgBox lr
p1:
x = Worksheets("Sheet1").Cells(i, "A")
c = WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A2:A" & lr), x)
MsgBox c
If c >= 2 Then
Worksheets("Sheet2").Cells(j, "A") = x
j = j + 1
i = i + c
Else
i = i + 1
End If
If i > lr Then Exit Sub
GoTo p1
End Sub
ーーー
例データ　Sheet1のA1:A15
項目
a
a
b
c
d
d
d
f
g
q
q
s
s
v
ーー
結果　Sheet2のA1以下に
a
d
q
s

回答No.1

ushi2015

こんにちは
http://okwave.jp/qa/q9198825.html
に回答したコードではダメなのですか？

Sub test()
　 Range("T3", Range("T" & Rows.Count).End(xlUp)).Sort _
　 Key1:=Range("T3"), Order1:=xlAscending, Header:=xlYes
　 Range("T3", Range("T" & Rows.Count).End(xlUp)).RemoveDuplicates _
　 Columns:=1, Header:=xlYes
End Sub