Soundex

Function Soundex(ByVal word As String) As String
    Dim result As String
    Dim i As Long, acode As Integer
    Dim dcode As Integer, oldCode As Integer
    
    ' soundex is case-insensitive
    word = UCase$(word)
    ' the first letter is copied in the result
    Soundex = Left$(word, 1)
    oldCode = Asc(Mid$("01230120022455012623010202", Asc(word) - 64))
    
    For i = 2 To Len(word)
        acode = Asc(Mid$(word, i, 1)) - 64
        ' discard non-alphabetic chars
        If acode >= 1 And acode <= 26 Then
            ' convert to a digit
            dcode = Asc(Mid$("01230120022455012623010202", acode, 1))
            ' don't insert repeated digits
            If dcode <> 48 And dcode <> oldCode Then
                Soundex = Soundex & Chr$(dcode)
                If Len(Soundex) = 4 Then Exit For
            End If
            oldCode = dcode
        End If
    Next
End Function

The Soundex code of an alphabetical string
you can use Soundex code for phonetic searches
Beware: this isn't bullet-proof!

UPDATE: this version corrects a bug in the original routine
        thanks to Edward Wittke for spotting the mistake

 
           Function Soundex(ByVal word As String) As String  
 
               Dim result As String  
 
               Dim i As Long, acode As Integer  
 
               Dim dcode As Integer, oldCode As Integer  
 
       ' soundex is case-insensitive 

               word = UCase$(word)  
 
       ' the first letter is copied in the result 

               Soundex = Left$(word, 1)  
 
               oldCode = Asc(Mid$("01230120022455012623010202", Asc(word) - 64))  
 
               For i = 2 To Len(word)  
 
                   acode = Asc(Mid$(word, i, 1)) - 64  
 
           ' discard non-alphabetic chars 

                   If acode >= 1 And acode <= 26 Then  
 
  ="commento">             ' convert to a digit 

                       dcode = Asc(Mid$("01230120022455012623010202", acode, 1))  
 
  ="commento">             ' don't insert repeated digits 

                       If dcode <> 48 And dcode <> oldCode Then  
 
                           Soundex = Soundex & Chr$(dcode)  
 
                           If Len(Soundex) = 4 Then Exit For  
 
                       End If  
 
                       oldCode = dcode  
 
                   End If  
 
               Next  
 
           End Function  
 
            The Soundex code of an alphabetical string  
 
           you can use Soundex code for phonetic searches  
 
           Beware: this isn't bullet-proof!  
 
           UPDATE: this version corrects a bug in the original routine  
 
                   thanks to Edward Wittke for spotting the mistake