'=========================================================
' Author: nerv            | E-mail: nerv-net@yandex.ru
' Last Update: 19/08/2011 | Яндекс.Деньги: 41001156540584
'=========================================================
Option Compare Binary
                  
Private Function CleanString(ByVal Str$) As String
Dim i%, s$, x As String * 1
Do While i < Len(Str)
       i = i + 1: x = Mid(Str, i, 1)
       If Not x Like "[0-9A-Za-zА-я ]" Then
           Select Case x
               Case "_": s = " ": Case "Ё": s = "Е"
               Case "ё": s = "е": Case Else: s = ""
           End Select
           Str = Replace(Str, x, s): i = i - 1
       End If
Loop
CleanString = Replace(Trim(Str), "  ", " ")
End Function

If "Вадимку" Like "блондинка" then

'=========================================================
' Author: nerv            | E-mail: nerv-net@yandex.ru
' Last Update: 27/09/2011 | Яндекс.Деньги: 41001156540584
'=========================================================
Public Function UniqueSortArr(ByRef v As Object)
Dim x, j, i&: On Error Resume Next
With New Collection
       For Each j In v.Areas
           For Each x In IIf(v.Count = 1, Array(v.Value), v.Value)
               If VarType(x) = vbString Then x = Trim(x)
               If Len(x) > 0 Then
                   If .Item(CStr(x)) = "" Then
                       For i = 1 To .Count
                           If x < .Item(i) Then
                     .Add x, CStr(x), Before:=i: Exit For
                           End If
                       Next
                       .Add x, CStr(x)
                   End If
               End If
           Next
       Next
       ReDim x(1 To .Count, 1 To 1)
       For i = 1 To .Count: x(i, 1) = .Item(i): Next
       UniqueSortArr = x
End With
End Function

Private Sub CommandButton1_Click()
Dim v
v = [A1:B8].Value
' Передаем массив
v = UniqueSortArr(v)
[D1].Resize(UBound(v, 1)) = v
' Передаем объекты - несмежные диапазоны. Можно ограничиться одним. Эт только для примера
v = UniqueSortArr([A19, B29:B30, A20, D19:D26, B23, A26:A27, B22])
[G18].Resize(UBound(v, 1)) = v
End Sub

'=========================================================
' Author: nerv            | E-mail: nerv-net@yandex.ru
' Last Update: 27/09/2011 | Яндекс.Деньги: 41001156540584
'=========================================================
Public Function UniqueSortArr(ByRef v As Object)
Dim x, j, i&: On Error Resume Next
With New Collection
       For Each j In v.Areas
           For Each x In IIf(v.Count = 1, Array(v.Value), v.Value)
               If VarType(x) = vbString Then x = Trim(x)
               If Len(x) > 0 Then
                   If .Item(CStr(x)) = "" Then
                       For i = 1 To .Count
                           If x < .Item(i) Then
                     .Add x, CStr(x), Before:=i: Exit For
                           End If
                       Next
                       .Add x, CStr(x)
                   End If
               End If
           Next
       Next
       ReDim x(1 To .Count, 1 To 1)
       For i = 1 To .Count: x(i, 1) = .Item(i): Next
       UniqueSortArr = x
End With
End Function

Private Sub CommandButton1_Click()
Dim v
v = [A1:B8].Value
' Передаем массив
v = UniqueSortArr(v)
[D1].Resize(UBound(v, 1)) = v
' Передаем объекты - несмежные диапазоны. Можно ограничиться одним. Эт только для примера
v = UniqueSortArr([A19, B29:B30, A20, D19:D26, B23, A26:A27, B22])
[G18].Resize(UBound(v, 1)) = v
End Sub

'=========================================================
' Author: nerv            | E-mail: nerv-net@yandex.ru
' Last Update: 24/09/2011 | Яндекс.Деньги: 41001156540584
'=========================================================
Option Compare Binary
Private Const PShift As Byte = 2
Private Type Box: Hsh As Long: Itm As Integer: End Type

Public Function HashCompare#(ByVal String1$, ByVal String2$, Optional ByRef LenComp As Byte = 0, Optional ByRef Register As Boolean = False)
Dim v, Ar(1 To 1024, 1) As Box, Str(1) As String, Ln(1) As Integer, j As Integer, i As Integer, x As Integer
Str(0) = String1: Str(1) = String2
For j = 0 To 1
      For Each v In Split(Prepare(Str(j), Register))
          If v <> vbNullString Then
              If LenComp = 0 Then
                  i = i + 1: Ar(i, j).Itm = 1
                  Ar(i, j).Hsh = EasyHash(CStr(v))
              Else
                  If Len(v) >= LenComp Then
                      For x = 1 To Len(v) - LenComp + 1
                          i = i + 1: Ar(i, j).Itm = x
                          Ar(i, j).Hsh = EasyHash(Mid(v, x, LenComp))
                      Next
                  End If
              End If
          End If
      Next
      Ln(j) = i: x = 0: i = 0
Next
For j = 1 To Ln(1)
      For i = 1 To Ln(0)
          If Ar(j, 1).Hsh = Ar(i, 0).Hsh Then
              If Abs(Ar(j, 1).Itm - Ar(i, 0).Itm) <= PShift Then
                  Ar(j, 1).Hsh = 0: Ar(i, 0).Hsh = 0: x = x + 1: Exit For
              End If
          End If
      Next
Next
HashCompare = x * 100 / IIf(Ln(1) < Ln(0), Ln(1), Ln(0))
End Function

Private Function Prepare$(ByRef Str$, Optional ByRef Register As Boolean = False)
Dim i As Long, Pattern As String, x As String * 1
Select Case Register
      Case False: Pattern = "[0-9a-zа-яё ]": Str = LCase(Str)
      Case True: Pattern = "[0-9A-Za-zА-яЁё ]"
End Select
Do While i < Len(Str)
      i = i + 1: x = Mid(Str, i, 1)
      If Not x Like Pattern Then
          Str = Replace(Str, x, " "): i = i - 1
      End If
Loop
Prepare = Trim(Str)
End Function

Private Function EasyHash(ByRef Str$) As Long
Dim i As Integer, Hash As Long
For i = 1 To Len(Str)
      Hash = i + 1664525 * AscB(Mid(Str, i, 1)) + 1013904223
      EasyHash = ((Hash Xor Abs(1365 / i)) And 65535) + EasyHash
Next
End Function