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
=====================================================
