vba removing duplicates from new set - excel

Question

The code below creates a new set of data on a new sheet but it takes everything that matches the requirements even if it is a duplicate. How can I change the code to eliminate duplicates in the new data set?
Sub Testerss()
Dim c As Range, v As String, arr, x As Long, e
Dim d As Range
Dim ws As Worksheet
Set d = Worksheets("Sheet3").Range("D1")
For Each c In ActiveSheet.Range("D25:D105")
v = Trim(c.Value)
If Len(v) > 0 Then
v = Replace(v, vbLf, " ")
Do While InStr(v, " ") > 0
v = Replace(v, " ", " ")
Loop
arr = Split(v, " ")
For x = LBound(arr) To UBound(arr)
e = arr(x)
If Not IsError(Application.Match(LCase(e), Array("(bye)", "(hello)"), 0)) Then
If x > LBound(arr) Then
d.Value = arr(x - 1) & " " & e
Else
d.Value = "??? " & e
End If
Set d = d.Offset(1, 0)
End If
Next x
End If
Next c
End Sub​

Answer 1

You could add a check to see if the result has already been copied over. First set a range of the results
finalRow = Worksheets("Sheet3").Cells(1000000, 4).end(xlup).row
Set resultRange = Worksheets("Sheet3").Range("D1:D" & finalRow)
Now see if the value you are currently examining is in that range
duplicate = false
for each result in resultRange
if v = result.Value then
duplicate = true
Exit For
end if
next
Now also check for duplicate before proceeding
If Len(v) > 0 and not duplicate then
All together
Set d = Worksheets("Sheet3").Range("D1")
For Each c In ActiveSheet.Range("D25:D105")
finalRow = Worksheets("Sheet3").Cells(1000000, 4).end(xlup).row
Set resultRange = Worksheets("Sheet3").Range("D1:D" & finalRow)
v = Trim(c.Value)
duplicate = false
for each result in resultRange
if v = result.Value then
duplicate = true
Exit For
end if
next
If Len(v) > 0 and not duplicate then
...