Макрос склонения ФИО на русском и украинском языках

' НОВАЯ ВЕРСИЯ ФУНКЦИИ СКЛОНЕНИЯ - дательный падеж

'==============================================================================================================================
' Module        : modNew
' Author        : Palant
' Professional application development for Microsoft Office
' Based on Author : EducatedFool from 07.01.2013 | ' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'  http://palikhov.wordpress.com e-mail: [e-mail]
'==============================================================================================================================

Option Compare Text    ' эта строка нужна обязательно! (сравнение без учёта регистра)

Function DativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
    ' Функция формирует дательный падеж из ФИО
    ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество
    ' © 2021 Palant, © 2013 Educated Fool

    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) - 1) & "ю"
                    Case "я", "а", "і": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "і"
                    Case "о": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "о"
                    Case Else: sRes = sSurnamePart & "у"
                End Select
                Select Case Right(sSurnamePart, 2)
                Case "ой": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ому"
                End Select

                
                Select Case Right(sSurnamePart, 3)
                Case "аха": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ці"
                Case "оха": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "сі"
                Case "чок": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 3) & "чок"
                Case "єць": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 3) & "йцю"
                Case "ньо": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 3) & "ню"
                Case "нок": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 3) & "нок"
                Case "ика": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 3) & "иці"
                End Select

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

            Else    ' женские фамилии
                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 Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ій"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ха", "ла", "ее": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "е"
'                    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
        DativeCase = Join(arrSurname, "-") & " "    ' соединяем части склоняемой фамилии обратно в одну строку
    End If

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

    If Len(sPatronymic) > 0 Then    '   Отчество
        If Right(sPatronymic, 4) = "огли" Or Right(sPatronymic, 4) = "кизи" Then
            DativeCase = DativeCase & sPatronymic
        Else
            If bMaleSex Then
                DativeCase = DativeCase & sPatronymic & "у"
            Else
                DativeCase = DativeCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "і"
            End If
        End If
    End If
    DativeCase = Replace(DativeCase, "-", "- ")
    DativeCase = StrConv(DativeCase, vbProperCase)
    DativeCase = Replace(DativeCase, "- ", "-")
End Function

Function GetDativeException(ByVal txt$) As String    ' склонение имён-исключений
    Select Case txt$
        Case "Павло": GetDativeException = "Павлу"
        Case "Лев": GetDativeException = "Льву"
        Case "Петро": GetDativeException = "Петру"
        Case "Михайло": GetDativeException = "Михайлу"
        Case "Марія": GetDativeException = "Марії"
        Case "Зоя": GetDativeException = "Зої"
        Case "Ігор": GetDativeException = "Ігорю"
        Case "Олеся": GetDativeException = "Олесі"
        Case "Дмитро": GetDativeException = "Дмитру"
        Case "Валерія": GetDativeException = "Валерії"
        Case "Любов": GetDativeException = "Любові"
        Case "Ольга": GetDativeException = "Ользі"

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

tags: WORK, DATA