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

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

 

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

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

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

Если вы используете функции склонения для формирования документов,
обратите внимание на специализированную надстройку FillDocuments,

которая позволит вам одним нажатием кнопки создать документы Word и Excel по шаблонам, а также выполнить рассылку писем.

В указанную надстройку включены самые последние версии функций склонения.

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

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

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

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

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

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

    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) & "е"
                        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) & "ому"
                    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) & "ую"
                End Select
 
            Else    ' женские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "е", "э", "и", "ы", "у", "ю", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _
                         "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь", "й": sRes = sSurnamePart
                    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) - 1) & "е"
                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 & 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 = txt$
    End Select
End Function

ВложениеРазмерЗагрузкиПоследняя загрузка
Dative_and_Genitive_Case.zip - склонение в родительный и дательный падеж на VBA72.28 КБ94 года 1 неделя назад
Dative_and_Genitive_Case.xls — версия от 30 октября 2014 года (с поддержкой разных алфавитов в ФИО)259.5 КБ0Ещё не загружался

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Здравствуйте! Большое спасибо за код и за сайт, с возможностью обучаться на Ваших примерах! Очень выручает.

Я взяла за основу Ваш код и заметила некоторые неточности в склонениях, (работу Марии заметила только что) все и не помню, вот только пока не сделала так, чтобы Фамилия Имя Отчество с окончанием "угли" корректно склонялась (Пример: Абдурасулов Абдуфаррух Абдурасул угли, Абдурасулов Азизхон Мухиддин угли, Мумедов Тулкин Йулдош угли),

а так же сделала для родительного падежа, там кажется все правильно получается.

'**************************************************************************
' склоняем ФИО в дательном падеже
'**************************************************************************

Function datelny(FIO As String) As String 
 
    Application.Volatile True
    Dim fname$(): fname = Split(FIO)
    If UBound(fname) < 2 Then Exit Function
    If Right(fname(2), 1) = "ч" Then
        'Склонение фамилии мужчины:
        If Right(fname(0), 2) = "хи" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ха"
        Else
        If Right(fname(0), 2) = "ак" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ак"
        Else
        If Right(fname(0), 2) = "як" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "як"
        Else
         If Right(fname(0), 2) = "ык" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ык"
        Else
          If Right(fname(0), 2) = "ок" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ок"
        Else
        If Right(fname(0), 2) = "ян" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ян"
        Else
         If Right(fname(0), 2) = "ик" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ик"
        Else
        If Right(fname(0), 2) = "ай" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ай"
        Else
        If Right(fname(0), 2) = "им" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "им"
        Else
 
 
            Select Case Right(fname(0), 1)
                Case "е", "о", "и", "я", "а", "с", "х", "т"
                Case "й": fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ому"
                Case "ь": fname(0) = Left(fname(0), Len(fname(0)) - 1) & "ю"
                Case Else: fname(0) = fname(0) & "у"
           End Select
        End If
        End If
        End If
        End If
        End If
        End If
        End If
        End If
        End If
 
 
 
        'Склонение мужского имени:
        Select Case Right(fname(1), 1)
            Case "л": fname(1) = fname(1) & "у"
            Case "д": fname(1) = fname(1) & "у"
            Case "ы": fname(1) = fname(1) & ""
            Case "а", "я": fname(1) = Left(fname(1), Len(fname(1)) - 1) & _
                                      IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "и", "и", "е")
            Case "й", "ь": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "ю"
            Case Else: fname(1) = fname(1) & "у"
        End Select
 
        'Склонение отчества
        Select Case Right(fname(2), 1)
            Case "л": fname(2) = fname(2) & "ю"
        End Select
 
         fname(2) = fname(2) & "у"
    Else
 
 
 
        'Склоенение женской фамилии
        Select Case Right(fname(0), 1)
            Case "о", "и", "й", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", _
                 "п", "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь"
            Case "я": fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ой"
            Case Else: fname(0) = Left(fname(0), Len(fname(0)) - 1) & "ой"
        End Select
        'Склонение женского имени
        Select Case Right(fname(1), 1)
            Case "а", "я": fname(1) = Left(fname(1), Len(fname(1)) - 1) & _
                                      IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "и", "е", "е")
            Case "ь": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "е"
        End Select
        'Склонение женского отчества
        fname(2) = Left(fname(2), Len(fname(2)) - 1) & "е"
    End If
    datelny = Join(fname)
End Function

'**************************************************************************
' склоняем ФИО в родительном падеже
'**************************************************************************

Function roditelny(FIO As String) As String ' склоняем ФИО в дательном падеже

    Application.Volatile True
    Dim fname$(): fname = Split(FIO)
    If UBound(fname) < 2 Then Exit Function
    If Right(fname(2), 1) = "ч" Then
        'Склонение фамилии мужчины:
        If Right(fname(0), 2) = "хи" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ха"
        Else
        If Right(fname(0), 2) = "ак" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ак"
        Else
        If Right(fname(0), 2) = "як" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "як"
        Else
         If Right(fname(0), 2) = "ык" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ык"
        Else
          If Right(fname(0), 2) = "ок" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ок"
        Else
        If Right(fname(0), 2) = "ян" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ян"
        Else
         If Right(fname(0), 2) = "ик" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ик"
        Else
        If Right(fname(0), 2) = "ай" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ай"
        Else
        If Right(fname(0), 2) = "им" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "им"
        Else
 
 
            Select Case Right(fname(0), 1)
                Case "е", "о", "и", "я", "а", "с", "х", "т"
                Case "й": fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ому"
                Case "ь": fname(0) = Left(fname(0), Len(fname(0)) - 1) & "ю"
                Case Else: fname(0) = fname(0) & "а"
           End Select
        End If
        End If
        End If
        End If
        End If
        End If
        End If
        End If
        End If
 
 
 
        'Склонение мужского имени:
        Select Case Right(fname(1), 1)
            Case "л": fname(1) = fname(1) & "а"
            Case "д": fname(1) = fname(1) & "а"
            Case "ы": fname(1) = fname(1) & ""
            Case "а", "я": fname(1) = Left(fname(1), Len(fname(1)) - 1) & _
                                      IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "у", "у", "у")
            Case "й", "ь": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "я"
            Case Else: fname(1) = fname(1) & "а"
        End Select
 
        'Склонение отчества
        Select Case Right(fname(2), 1)
            Case "л": fname(2) = fname(2) & "а"
        End Select
 
         fname(2) = fname(2) & "а"
    Else
 
 
 
        'Склоенение женской фамилии
        Select Case Right(fname(0), 1)
            Case "о", "и", "й", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", _
                 "п", "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь"
            Case "я": fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ю"
            Case Else: fname(0) = Left(fname(0), Len(fname(0)) - 1) & "у"
        End Select
        'Склонение женского имени
        Select Case Right(fname(1), 1)
            Case "а": fname(1) = Left(fname(1), Len(fname(1)) - 1) & _
                                      IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "у", "у", "у")
 
 
            Case "я": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "ю"
            Case "ь": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "ь"
        End Select
 
        'Склонение женского отчества
        fname(2) = Left(fname(2), Len(fname(2)) - 1) & "у"
    End If
'    End If
    roditelny = Join(fname)
End Function

Возможно не все гладко изменила, в коде, за что заранее извиняюсь.

Ну и я поработала над этим макросом: исправила склонения имен Павел, Михаил, добавила склонение мужских фамилий с окончанием -а. Женские фамилии, вроде Кашуба, победить не смогла, как и особенности склонения отчеств кызы (с ними и без макроса взрыв мозга). Но это мелочи, большинство ФИО переводит как надо!! Спасибо, разработчику!

Function datelny(fio As String) As String
    Application.Volatile True
    Dim fname$(): fname = Split(fio)
    If UBound(fname) < 2 Then Exit Function
    If Right(fname(2), 1) = "ч" Then
        'Склонение фамилии мужчины:
        If Right(fname(0), 2) = "хи" Then
            fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ха"
        Else
            Select Case Right(fname(0), 1)
                Case "е", "о", "и", "я"
                Case "а": fname(0) = Left(fname(0), Len(fname(0)) - 1) & "е"
                Case "й": fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ому"
                Case "ь": fname(0) = Left(fname(0), Len(fname(0)) - 1) & "ю"
                Case Else: fname(0) = fname(0) & "у"
            End Select
        End If
        'Склонение мужского имени:
        If Right(fname(1), 2) = "ил" Then
            fname(1) = Left(fname(1), Len(fname(1)) - 1) & "ил"
        End If
        Select Case Right(fname(1), 1)
            Case "л": fname(1) = Left(fname(1), Len(fname(1)) - 2) & "лу"
            Case "а", "я": fname(1) = Left(fname(1), Len(fname(1)) - 1) & _
                                      IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "и", "и", "е")
            Case "й", "ь": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "ю"
            Case Else: fname(1) = fname(1) & "у"
        End Select
        'Склонение отчества
        fname(2) = fname(2) & "у"
    Else
        'Склоенение женской фамилии
        Select Case Right(fname(0), 1)
            Case "о", "и", "й", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", _
                 "п", "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь"
            Case "я": fname(0) = Left(fname(0), Len(fname(0)) - 2) & "ой"
            Case Else: fname(0) = Left(fname(0), Len(fname(0)) - 1) & "ой"
        End Select
        'Склонение женского имени
        Select Case Right(fname(1), 1)
            Case "а", "я": fname(1) = Left(fname(1), Len(fname(1)) - 1) & _
                                      IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "и", "и", "е")
            Case "ь": fname(1) = Left(fname(1), Len(fname(1)) - 1) & "и"
        End Select
        'Склонение женского отчества
        fname(2) = Left(fname(2), Len(fname(2)) - 1) & "е"
    End If
    datelny = Join(fname)
End Function

думаю в UDF строку
Dim bMaleSex As Boolean: bMaleSex = (Right(sPatronymic, 1) = "ч")

попрбовать заменить на
Dim bMaleSex As Boolean: bMaleSex = (Right(sPatronymic, 1) = "ч" Or Right(sPatronymic, 2) = "зы")

Хорошо бы еще учесть отчества с "кызы"...

ну не так выразился сори. как отдельно фамилии добавлять я разобрался
If bMaleSex Then
Select Case (sSurname)
Case "паршивлюк", "хомяк": DativeCase = sSurname
End Select
End If
а мне надо это он брал эти фамилии из файла! что бы не прописывать постоянно по 1 фамилии, а просто пополнять файл и все.

Какая «прога»? В статье опубликован обычный макрос для Excel...
Встройте этот макрос в файл с несклоняемыми фамилиями - и проблем не будет.
Правда, макрос придется модернизировать, чтобы он учитывал эти фамилии.

а как сделать так, что бы прога ссылалась на файл где лежат несклоняемые фамилии?

UDF неверно склоняет имя Павел, получается "Павелу"
После строки
Case "й", "ь": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & "ю"
Решил добавлением строки
Case "л": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 2) & "лу"

Фамилию Губа оба варианта склоняют как Губой, конечно вариант непростой, насколько я знаю, если фамилию носит мужчина то склоняется, в случае, если женщина то нет.

Исправил. Прикрепил обновлённый файл.

Игорь, исправь ошибку в UDF
IIf(Mid(fname(1), Len(fname(1)) - 2, 1) = "и", "и", "е")
нужно заменить на
IIf(Mid(fname(1), Len(fname(1)) - 1, 1) = "и", "и", "е")

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
         _   ____                      
___ (_) / ___| ___ _ __ __ __
/ __| | | \___ \ / __| | '__| \ \/ /
| (__ | | ___) | \__ \ | | > <
\___| |_| |____/ |___/ |_| /_/\_\
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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