Макросы и функции VBA

Функция "Родительный падеж фамилии, имени, отчества"


Формирует родительный падеж фамилии, имени, отчества.

=GenitiveCase(A1), =GenitiveCase(A1;B1;C1), =GenitiveCase(A1;B1), где:

• sSurname - фамилия;

• sName - имя;

• sPatronymic - отчество.



Option Compare Text 'сравнение без учета регистра
Function GenitiveCase(sSurname$, Optional sName$, Optional sPatronymic$) As String

    Application.Volatile True 'автопересчет формулы на листе
    sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")

    On Error Resume Next
    If sName$ = "" And sPatronymic$ = "" Then
        arr = Split(Application.Trim(sSurname$))
        sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2), ".", "")
    End If

    'заканчивается на "вна" или "кызы" - женщины, остальные - мужчины
    Dim bMaleSex As Boolean: 'bMaleSex = (Right(sPatronymic, 1) = "ч" Or Right(sPatronymic, 4) = "оглы")
    bMaleSex = Not (Right(sPatronymic, 2) = "на" Or Right(sPatronymic, 4) = "кызы")

    If Len(sSurname) > 0 Then 'фамилия
        arrSurname = Split(sSurname, "-")
        For i = LBound(arrSurname) To UBound(arrSurname) 'перебираем все части фамилий, содержащих дефис
            sRes = "": sSurnamePart = arrSurname(i)

            If bMaleSex Then 'мужские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "и", "ы", "у", "э", "е", "ю": sRes = sSurnamePart
                    Case "й": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"
                    Case "ь": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "и"
                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "и"
                        If UBound(arrSurname) > 0 And i = 0 Then sRes = sSurnamePart
                    Case Else: sRes = sSurnamePart & "а"
                End Select

                Select Case Right(sSurnamePart, 2) 'добавлено, для редких фамилий
                    Case "ец":  sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ца"
                        If LCase(sSurnamePart) Like "*[уеыаоэяиюё]ец" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ца"
                        If LCase(sSurnamePart) Like "*[!уеыаоэяиюё][!уеыаоэяиюё]ец" Then sRes = sSurnamePart & "а"
                    Case "зе", "их", "ых": sRes = sSurnamePart
                    Case "ий", "ой": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"
                        If Len(sSurnamePart) <= 4 Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"
                        If Right(sSurnamePart, 3) = "чий" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "его"
                    Case "уй": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "уя"
                    Case "ра": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ры"
                    Case "на": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ны"
                End Select

            Else 'женские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "е", "э", "и", "ы", "у", "ю", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _
                         "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь", "й": sRes = sSurnamePart
                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ой"
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ю"
                    Case Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "у"
                End Select

                Select Case Right(sSurnamePart, 2) 'добавлено для редких фамилий
                    Case "ха": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "хи"
                    Case "ла": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "лы"
                    Case "ая": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ой"
                End Select

            End If

'не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю,
'а также на -а с предшествующей гласной
            If LCase(sSurnamePart) Like "*[уеыаоэяиюё]а" Then sRes = sSurnamePart

            arrSurname(i) = sRes
        Next
        GenitiveCase = Join(arrSurname, "-") & " " 'соединяем части склоняемой фамилии обратно в одну строку
    End If

    If Len(sName) > 0 Then 'имя
        NameException$ = GetGenitiveException(sName)
        If Len(NameException$) Then 'для имен-исключений
            GenitiveCase = GenitiveCase & NameException$
        Else 'имя не найдено в списке исключений
            If bMaleSex Then
                Select Case Right(sName, 1)
                    Case "й", "ь": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "я"
                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case "о": GenitiveCase = GenitiveCase & sName
                    Case Else: GenitiveCase = GenitiveCase & sName & "а"
                End Select
            Else
                Select Case Right(sName, 1)
                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case Else: GenitiveCase = GenitiveCase & sName
                
                End Select
            End If
        End If
        GenitiveCase = GenitiveCase & " "
    End If

    If Len(sPatronymic) > 0 Then 'отчество
        If Right(sPatronymic, 4) = "оглы" Or Right(sPatronymic, 4) = "кызы" Then
            GenitiveCase = GenitiveCase & sPatronymic
        Else
            If bMaleSex Then
                GenitiveCase = GenitiveCase & sPatronymic & "а"
            Else
                GenitiveCase = GenitiveCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "ы"
            End If
        End If
    End If
    GenitiveCase = Replace(GenitiveCase, "-", "- ")
    GenitiveCase = StrConv(GenitiveCase, vbProperCase)
    GenitiveCase = Replace(GenitiveCase, "- ", "-")
End Function
Function GetGenitiveException(ByVal txt$) As String 'склонение имен-исключений
    Select Case txt$
        Case "Павел": GetGenitiveException = "Павла"
        Case "Лев": GetGenitiveException = "Льва"
        Case "Пётр": GetGenitiveException = "Петра"
        Case "Петр": GetGenitiveException = "Петра"
        Case "Любовь": GetGenitiveException = "Любови"
        Case "Ольга": GetGenitiveException = "Ольги"
        Case "Вероника": GetGenitiveException = "Вероники"

'без изменения (не склоняются) - перечисляем через запятую
        Case "Али", "Бали": GetGenitiveException = txt$
    End Select
End Function


    img01

    Финансы

    Бухгалтеру, экономисту, финансисту Вход
    img02

    Право

    Юристу, специалисту по кадрам Вход
    img03

    Канцелярия

    Делопроизводителю, секретарю Вход
    img04

    Транспорт

    Логисту, механику, водителю Вход
    img05

    IT

    Системному администратору Вход
    img06

    Менеджмент

    Начальникам отделов Вход