Sub RemovePersianDuplicates()
Dim ary As Variant
Dim dict As Object
Dim i As Long, j As Long, k As Long
Dim latin_comma As Boolean
Dim rng As Range
Dim txt As String
Dim word As Variant
Dim word_ary As Variant
Dim word_coll As New Collection
Application.ScreenUpdating = False
With ActiveSheet
Set rng = Intersect(Range(.Columns(1), .Columns(7)), .UsedRange)
End With
ary = rng.Value2
For i = LBound(ary, 1) To UBound(ary, 1)
For j = LBound(ary, 2) To UBound(ary, 2)
txt = CStr(ary(i, j))
' Parse txt only if it contains more than one word.
If txt <> "" And InStr(Trim(txt), " ") > 0 Then
' Remove the POP DIRECTIONAL FORMATTING character, U+202C.
txt = Replace(txt, ChrW(&H202C), "")
' Change Farsi YEH to Arabic YEH.
txt = Replace(txt, ChrW(1740), ChrW(1610))
' Latin comma+space or Persian comma with no space?
latin_comma = True
If InStr(txt, ChrW(1548)) > 0 Then latin_comma = False
' Grab the first Latin word.
txt = Replace(txt, " ", "|", Count:=1)
word_ary = Split(txt, "|")
word_coll.Add word_ary(0), word_ary(0)
txt = word_ary(1)
' Split the remaining words on the commas.
txt = Replace(txt, ChrW(1548), "|")
txt = Replace(txt, ",", "|")
' txt = Replace(txt, " ", "")
word_ary = Split(txt, "|")
' Remove the duplicates.
On Error Resume Next
For Each word In word_ary
word_coll.Add word, word
Next word
On Error GoTo 0
' Reassemble the entire string.
txt = word_coll(1)
For k = 2 To word_coll.Count
If k = 2 Then
txt = txt & " " & word_coll(k)
ElseIf latin_comma Then
txt = txt & ", " & word_coll(k)
Else
txt = txt & ChrW(1548) & word_coll(k)
End If
Next k
ary(i, j) = txt
Set word_coll = Nothing
End If
Next j
Next i
' Send the texts to the worksheet.
rng.Value2 = ary
Application.ScreenUpdating = True
End Sub
