You might be able to compute the Levenshtein distance between the words and, if there are only a few letters different, assume they are the same. The macro below assumes that if the distance is one or two letters, then thewords are the same, so it will only return the first one. You'll have to test this, and see whether two is appropriate. It does work on your limited sample.

The macro below assumes the list of fruits/vegetables is in column A, andwill put the results into the adjacent column.

As written, the results are all capitalized.

If this idea works on your data, the capitalization can be changed; the results column can be changed; and, if necessary, the routine can be sped upconsiderably.

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.

Ensure your project is highlighted in the Project Explorer window.

Then, from the top menu, select Insert/Module and

paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.

==================================

Option Explicit

Sub UniqueSimilars()

Dim Rg As Range, c As Range

Dim rRes As Range

Dim col As Collection

Dim i As Long, j As Long, k As Long

Dim v() As Variant

Set Rg = Range("A1", Cells(Rows.Count, "A").End(xlUp))

Set col = New Collection

On Error Resume Next

For Each c In Rg

col.Add Item:=UCase(c.Text), Key:=c.Text

Next c

On Error GoTo 0

ReDim v(1 To col.Count)

For i = 1 To col.Count

For j = LBound(v) To UBound(v)

k = LD(col(i), v(j))

If k <= 2 Then Exit For

Next j

If k > 2 Then v(i) = col(i)

Next i

j = 1

Set rRes = Rg(1, 1).Offset(0, 1)

rRes.EntireColumn.Clear

For i = LBound(v) To UBound(v)

If Len(v(i)) > 0 Then

rRes(j, 1) = v(i)

j = j + 1

End If

Next i

End Sub

'********************************

'*** Compute Levenshtein Distance

'********************************

'

http://www.merriampark.com/ld.htm#VB
Private Function LD(ByVal s As String, ByVal t As String) As Long

Dim d() As Long ' matrix

Dim m As Long ' length of t

Dim n As Long ' length of s

Dim i As Long ' iterates through s

Dim j As Long ' iterates through t

Dim s_i As String ' ith character of s

Dim t_j As String ' jth character of t

Dim cost As Long ' cost

' Step 1

n = Len(s)

m = Len(t)

If n = 0 Then

LD = m

Exit Function

End If

If m = 0 Then

LD = n

Exit Function

End If

ReDim d(0 To n, 0 To m) As Long

' Step 2

For i = 0 To n

d(i, 0) = i

Next i

For j = 0 To m

d(0, j) = j

Next j

' Step 3

For i = 1 To n

s_i = Mid$(s, i, 1)

' Step 4

For j = 1 To m

t_j = Mid$(t, j, 1)

' Step 5

If s_i = t_j Then

cost = 0

Else

cost = 1

End If

' Step 6

d(i, j) = Minimum(d(i - 1, j) + 1, d(i, j - 1) + 1, d(i - 1, j - 1) + cost)

Next j

Next i

' Step 7

LD = d(n, m)

Erase d

End Function

'*******************************

'*** Get minimum of three values

'*******************************

Private Function Minimum(ByVal a As Long, _

ByVal b As Long, _

ByVal c As Long) As Long

Dim mi As Long

mi = a

If b < mi Then

mi = b

End If

If c < mi Then

mi = c

End If

Minimum = mi

End Function

=====================================================