Results 1 to 3 of 3
  1. #1
    Join Date
    Aug 2011

    Unanswered: soundex and metaphone in vba


    Can u help me to find the vba code for the Soundex and the Metaphone functions please ?

    Many thanks

  2. #2
    Join Date
    Sep 2009
    Provided Answers: 1
    I posted a cobol verson of soundex here, you should be able to translate the cobol to whatever.
    OpenCOBOL - Forum

  3. #3
    weejas is offline Grumpy old man (training)
    Join Date
    Sep 2006
    Surrey, UK
    Provided Answers: 17
    I don't know the Metaphone function, but here's a VBA version that returns the Russell Soundex value for a string:
    Function RSOUNDEX(ByVal strInput As String) As String
        'This is based on the Russell Soundex algorithm, and returns a string of up to four characters
        'that holds the Soundex value
        'Vowels exist only as dividers.  Consecutive consonants with matching Soundex values are treated
        'as one occurrence.  W and H only have an effect as the initial letter.
        Dim strThisChar As String * 1
        Dim strPrevChar As String * 1
        Dim strSoundex As String * 1
        Dim strOut As String
        Dim strWork As String
        Const cintSLen As Integer = 4
        strOut = Left(UCase(strInput), 1)
        strWork = UCase(Right(strInput, Len(strInput) - 1))
        strThisChar = Left(strWork, 1)
        strWork = Right(strWork, Len(strWork) - 1) & " "
        strPrevChar = strOut
        Do Until Len(strOut) = cintSLen Or strWork = ""
            'strThisChar = Left(strWork, 1)
            'Get the Soundex value for this letter
            strSoundex = SoundexValue(strThisChar)
            If Not (strSoundex = " " Or strSoundex = SoundexValue(strPrevChar)) Then
                strOut = strOut & strSoundex
            End If
            strPrevChar = strThisChar
            strThisChar = Left(strWork, 1)
            strWork = Right(strWork, Len(strWork) - 1)
        RSOUNDEX = strOut
    End Function
    Function SoundexValue(strLetter As String) As String
    'Return the soundex value of the supplied letter
    Select Case strLetter
        Case "A", "E", "H", "I", "O", "U", "W"
            SoundexValue = ""
        Case "B", "F", "P", "V"
            SoundexValue = "1"
        Case "C", "G", "J", "K", "Q", "S", "X", "Z"
            SoundexValue = "2"
        Case "D", "T"
            SoundexValue = "3"
        Case "L"
            SoundexValue = "4"
        Case "M", "N"
            SoundexValue = 5
        Case "R"
            SoundexValue = "6"
        Case Else
            SoundexValue = ""
    End Select
    End Function
    You can then encapsulate that within this one to show how similar two strings are:
    Function RSOUNDEXCOMP(strVal1 As String, strVal2 As String, Optional booSoundex As Boolean = False) As Integer
        'Function sort of taken from Getz & Gilbert "VBA Developer's Handbook" 2nd edition
        'Convert the values into Soundex values if required and report how similar they are
        Dim intLoop As Integer
        If Not booSoundex Then
            strVal1 = RSOUNDEX(strVal1)
            strVal2 = RSOUNDEX(strVal2)
        End If
        If strVal2 = strVal1 Then
            RSOUNDEXCOMP = 4
            Exit Function
        End If
        For intLoop = 1 To cintSLen
            If Mid(strVal1, intLoop, 1) <> Mid(strVal2, intLoop, 2) Then
                Exit For
            End If
        Next intLoop
        RSOUNDEXCOMP = intLoop - 1
    End Function
    10% of magic is knowing something that no-one else does. The rest is misdirection.
    Beers earned: 2

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts