Пользовательская функция (UDF) для перевода ФИО (фамилии, имя, отчества) в дательный падеж.
Новые версии функций (изменения от 2019 года) доступны в надстройке FIO + Propis
Эту функцию можно использовать как в коде программы, так и как формулу в ячейках листа 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
Комментарии
Неплохо. А есть творительный падеж? Мне надо именно творительный падеж.
Сделал аналогичную UDF функцию для родительного падежа:
http://excelvba.ru/code/GenitiveCase
К обеим статьям прикрепил обновлённый файл - теперь, на тестовых данных,
обе функции не дают ни единой ошибки.
Отлично!!! Спасибо, с удовольствием забираю! ;))
Владимир, спасибо за замечания.
Внёс исправления в код (в статье, и прикреплённом файле)
На книгу у меня времени нет, - код можно усложнять до бесконечности (вспомните, например, фамилии и имена-исключения, иностранные фамилии, и т.д.)
Всего, в любом случае, не предусмотришь.
Моей целью было сделать функцию, которая в подавляющем большинстве случаев давала бы верный ответ
(я теперь встроил эту функцию в свою программу заполнения документов)
Вроде бы, с этой задачей я справился)
Здравствуйте, Игорь! Спасибо за интересный сайт! Несколько замечаний:
1. Женские отчества могут оканчиваться на "чна" (Ильинична)
2. Не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю, а также на -а с предшествующей гласной (Ваш список не полный).
3. Если мужской фамилии, оканчивающейся на -ец, предшествует гласная (Бугаец), то эта гласная не должна выпадать при склонении.
Может быть, Вам будет интересна книга Л.П.Калакуцкой "Склонение фамилий и личных имен в русском литературном языке" (могу прислать в pdf-формате).
Уведомляю, что стала доступна новая версия функции для склонения в дательный падеж.
Код функции заметно переработан (и усложнён).
Основные изменения:
Во вложении к статье - тестовый файл, где есть результаты склонения новой функцией (всего 3 ошибки на 177 ФИО),
результат использования прежней функции datelny, с вариантами от МСН, Марии и Светланы (соответственно, 44, 42 и 49 ошибок на 177 ФИО),
а также аналогичная функция от KrukVN (23 ошибки на 177 ФИО)
PS: В ближайшее время, постараюсь аналогично доработать функцию для склонения в родительный падеж.
Здравствуйте! Большое спасибо за код и за сайт, с возможностью обучаться на Ваших примерах! Очень выручает.
Я взяла за основу Ваш код и заметила некоторые неточности в склонениях, (работу Марии заметила только что) все и не помню, вот только пока не сделала так, чтобы Фамилия Имя Отчество с окончанием "угли" корректно склонялась (Пример: Абдурасулов Абдуфаррух Абдурасул угли, Абдурасулов Азизхон Мухиддин угли, Мумедов Тулкин Йулдош угли),
а так же сделала для родительного падежа, там кажется все правильно получается.
Возможно не все гладко изменила, в коде, за что заранее извиняюсь.
Ну и я поработала над этим макросом: исправила склонения имен Павел, Михаил, добавила склонение мужских фамилий с окончанием -а. Женские фамилии, вроде Кашуба, победить не смогла, как и особенности склонения отчеств кызы (с ними и без макроса взрыв мозга). Но это мелочи, большинство ФИО переводит как надо!! Спасибо, разработчику!
думаю в 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) = "и", "и", "е")
Отправить комментарий