Функция перевода ФИО в родительный падеж

Пользовательская функция (UDF) для перевода ФИО (фамилии, имя, отчества) в родительный падеж.

Эту функцию можно использовать как в коде программы, так и как формулу в ячейках листа Excel
(см. пример в прикреплённом файле)

PS: Функция является переделкой аналогичной UDF для склонения в дательном падеже.
Тестировал склонение на списке разнообразных ФИО (см. первый столбец в прикреплённом файле), и заведомо корректных результатах склонения (третий столбец)

Конечно, код не идеальный, - всегда можно найти ФИО, которые будут склоняться неверно.
Но, в целом, удалось добиться весьма неплохого результата (по сравнению с прежней версией кода, и другими аналогичными функциями)

Пример использования:

Sub ПереводФИОвРодительныйПадеж()
    ' если фамилия, имя и отчество - в одной переменной (или ячейке)
    FIO$ = "Сидоров Иван Скотиныч"
    РодительныйПадеж$ = GenitiveCase(FIO$)
    Debug.Print РодительныйПадеж$    ' результат: Сидорова Ивана Скотиныча

    ' если фамилия, имя и отчество - в разных переменных (или ячейках)
    НетКого$ = GenitiveCase("Андреева", "Ольга", "Федоровна")
    Debug.Print НетКого$    ' результат: Андреевой Ольги Федоровны
End Sub

Код функции GenitiveCase (версия от 29 января 2013 года):

<br />Option Compare Text    ' эта строка нужна обязательно! (сравнение без учёта регистра)</p><p>Function GenitiveCase(sSurname$, Optional sName$, Optional sPatronymic$) As String<br />    ' Функция формирует родительный падеж из ФИО<br />    ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество<br />    ' © 2013 EducatedFool</p><p>    Application.Volatile True    ' автопересчёт формулы на листе<br />    sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")</p><p>    On Error Resume Next<br />    If sName$ = "" And sPatronymic$ = "" Then<br />        arr = Split(Application.Trim(sSurname$))<br />        sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2), ".", "")<br />    End If</p><p>    ' пол теперь определяется иначе:   что заканчивается на "вна" или "кызы" - то женщины, остальные - мужчины.<br />    Dim bMaleSex As Boolean:    ' bMaleSex = (Right(sPatronymic, 1) = "ч" Or Right(sPatronymic, 4) = "оглы")<br />    bMaleSex = Not (Right(sPatronymic, 2) = "на" Or Right(sPatronymic, 4) = "кызы")</p><p>    If Len(sSurname) > 0 Then    '   Фамилия<br />        arrSurname = Split(sSurname, "-")<br />        For i = LBound(arrSurname) To UBound(arrSurname)    ' перебираем все части фамилий, содержащих дефис<br />            sRes = "": sSurnamePart = arrSurname(i)</p><p>            If bMaleSex Then    ' мужские фамилии<br />                Select Case Right(sSurnamePart, 1)<br />                    Case "о", "и", "ы", "у", "э", "е", "ю": sRes = sSurnamePart<br />                    Case "й": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"<br />                    Case "ь": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"<br />                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "и"<br />                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ы"<br />                        If UBound(arrSurname) > 0 And i = 0 Then sRes = sSurnamePart<br />                    Case Else: sRes = sSurnamePart & "а"<br />                End Select</p><p>                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий<br />                    Case "ец":  sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ца"<br />                        If LCase(sSurnamePart) Like "*[уеыаоэяиюё]ец" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ца"<br />                        If LCase(sSurnamePart) Like "*[!уеыаоэяиюё][!уеыаоэяиюё]ец" Then sRes = sSurnamePart & "а"<br />                    Case "зе", "их", "ых": sRes = sSurnamePart<br />                    Case "ий", "ой": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"<br />                        If Len(sSurnamePart) <= 4 Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"<br />                        If Right(sSurnamePart, 3) = "чий" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "его"<br />                    Case "уй": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "уя"<br />                End Select</p><p>            Else    ' женские фамилии<br />                Select Case Right(sSurnamePart, 1)<br />                    Case "о", "е", "э", "и", "ы", "у", "ю", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _<br />                         "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь", "й": sRes = sSurnamePart<br />                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ой"<br />                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ю"<br />                    Case Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "у"<br />                End Select</p><p>                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий<br />                    Case "ха": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "хи"<br />                    Case "ла": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "лы"<br />                    Case "ая": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ой"<br />                End Select</p><p>            End If</p><p>            ' не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю,<br />            ' а также на -а с предшествующей гласной<br />            If LCase(sSurnamePart) Like "*[уеыаоэяиюё]а" Then sRes = sSurnamePart</p><p>            arrSurname(i) = sRes<br />        Next<br />        GenitiveCase = Join(arrSurname, "-") & " "    ' соединяем части склоняемой фамилии обратно в одну строку<br />    End If</p><p>    If Len(sName) > 0 Then    '   Имя<br />        NameException$ = GetGenitiveException(sName)<br />        If Len(NameException$) Then    ' для имен-исключений<br />            GenitiveCase = GenitiveCase & NameException$<br />        Else    ' имя не найдено в списке исключений<br />            If bMaleSex Then<br />                Select Case Right(sName, 1)<br />                    Case "й", "ь": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "я"<br />                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"<br />                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"<br />                    Case "о": GenitiveCase = GenitiveCase & sName<br />                    Case Else: GenitiveCase = GenitiveCase & sName & "а"<br />                End Select<br />            Else<br />                Select Case Right(sName, 1)<br />                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"<br />                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"<br />                    Case Else: GenitiveCase = GenitiveCase & sName<br />                End Select<br />            End If<br />        End If<br />        GenitiveCase = GenitiveCase & " "<br />    End If</p><p>    If Len(sPatronymic) > 0 Then    '   Отчество<br />        If Right(sPatronymic, 4) = "оглы" Or Right(sPatronymic, 4) = "кызы" Then<br />            GenitiveCase = GenitiveCase & sPatronymic<br />        Else<br />            If bMaleSex Then<br />                GenitiveCase = GenitiveCase & sPatronymic & "а"<br />            Else<br />                GenitiveCase = GenitiveCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "ы"<br />            End If<br />        End If<br />    End If<br />    GenitiveCase = Replace(GenitiveCase, "-", "- "):    GenitiveCase = StrConv(GenitiveCase, vbProperCase):    GenitiveCase = Replace(GenitiveCase, "- ", "-")<br />End Function<br />
<br />Function GetGenitiveException(ByVal txt$) As String    ' склонение имён-исключений<br />    Select Case txt$<br />        Case "Павел": GetGenitiveException = "Павла"<br />        Case "Лев": GetGenitiveException = "Льва"<br />        Case "Пётр": GetGenitiveException = "Петра"<br />        Case "Любовь": GetGenitiveException = "Любови"</p><p>            ' без изменения (не склоняются) - перечисляем через запятую<br />        Case "Али", "Бали": GetGenitiveException = txt$<br />    End Select<br />End Function<br />