mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

Пользовательская функция (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 КБ93 года 31 неделя назад
Dative_and_Genitive_Case.xls — версия от 30 октября 2014 года (с поддержкой разных алфавитов в ФИО)259.5 КБ0Ещё не загружался

Комментарии

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

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

Здравствуйте, Владимир
Перед склонением добавляйте слово до и после (любую фамилию и любое отчество), а после применения функции - удаляйте лишние слова (взяв только второе)
Итого, 2 дополнительные строки кода.

Здравствуйте!
Хотел просклонять в дательном падеже только имена.
Однако просто имена в частности
Евгений
Георгий
склоняет не верно.
Получается (Евгеному, Георгому)
Только если пишешь полные ФИО
подскажите пожалуйста где надо поправить...?
Или выложите поправленный файл, буду Вам очень признателен.

Добрый день! У меня аналогичная проблема. В паспортных данных "оглы" идет без тире. Подстановка указанных вами строк проблему не исправляет.

спасибо, очень полезная функция!
вот только армянские фамилии не склоняются, открыл Dative_and_Genitive_Case.xls и сразу бросилось в глаза)

Владислав, да, есть и для винительного
Все эти функции (последние их версии) присутствуют в моей надстройке для заполнения документов:
http://excelvba.ru/programmes/FillDocuments

можно и отдельно найти, если в поисковике (яндекс или гугл) набрать следующую фразу:
AccusativeCase Функция формирует ВИНИТЕЛЬНЫЙ падеж из ФИО

Спасибо, работает.
Еще вопрос- есть ли такой же макрос для винительного падежа?

Владислав, после строки

Select Case Right(sSurnamePart, 2)        ' добавлено, для редких фамилий

добавьте строку
Case "га", "ша", "жа", "йа", "ка", "ча", "ща": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "и"

Здравствуйте!
Попалась фамилия, которая неправильно склоняется в родительный падеж - Митрога Евгений Валентинович. Получается "Митрогы", а должно быть "Митроги". Подскажите, что надо изменить в макросе, чтобы склонялось правильно. Спасибо.

Указанные в предыдущем комментарии строки разместите в функции DativeCase после строки
sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")

Если сами не разберетесь, то в форме оформления заказа (см. кнопку наверху страницы - http://excelvba.ru/order/send) разместите пример исходного файла и что хотите получить.

А это где нужно заменить? Как не пробал не получается.

Если в исходных данных нет тире, а кызы и оглы отделены пробелом, то замените кызы и оглы на -кызы и -оглы.

sPatronymic$ = Replace(sPatronymic$, " кызы", "-кызы")
sPatronymic$ = Replace(sPatronymic$, " оглы", "-оглы")

В конце, если не нужно тире, можете сделать обратную замену.

Я понял у меня не срабатывает из-за тире. Тире нет по паспорту как-то можно это исправить в макросе?

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

Напишите пожалуйста макрос только для фамилий и только для замены на дательный падеж (соответственно с привязкой к определенной ячейке, например: Лист - О_продлении, ячейка - M14). Спасибо.

Чтобы Excel не тормозил при пересчёте, - удалите в коде эту строку:

Application.Volatile True    ' автопересчёт формулы на листе

Оглы и кызы в отчестве дописывать - это как?
Вроде всё работает как надо:

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

    FIO$ = "Сидорова Лейла Салим-кызы"
    Debug.Print DativeCase(FIO$)   ' результат: Сидоровой Лейле Салим-Кызы
End Sub

Здравствуйте! Большое спасибо за макрос часто им пользуюсь. Как-то можно сделать чтобы excel расчет не запускал т.к. -замедляет (тормозит) работу Excel`я? Как сделать чтобы Оглы дописывал в отчестве.

Роман, тут ничем не помогу
Функция предназначена ТОЛЬКО ДЛЯ СКЛОНЕНИЯ ФИО.
Ничего другого она склонять не умеет, - потому и ошибки в вашем случае.

Доброго времени суток. столкнулся с проблемой склонения званий. например при склонении "младший сержант" получается "младшому сержанту" вместо "младшему сержанту" аналогично с воинскими званиями с приставкой старший. помогите кто чем может!!!

Эх, а так хотелось! Спасибо!

Можно, - но намного сложнее, чем из именительного в дательный
Исходную форму ФИО, в общем случае, не восстановить.
Например, возьмём 3 фамилии: Босой, Босый и Босий
В дательном все 3 будут выглядеть одинаково, - Босому
А вот обратное преобразование с вероятностью больше 50% даст неверный результат (никак не угадать, какая фамилия была изначально)
Потому, у меня такого макроса нет, и не будет.

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

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

Здравствуйте. Подскажите, пожалуйста, где поправить код макроса чтобы можно было его использовать для склонений предприятий. Если есть филиал (например, Санкт-Петербургский филиал, а записывается после макроса Санкт-Петербургского Филиала) и я использую Вашу функции, то второе слово пишется с большой буквы.. Как исправить ее на маленькую..

Здравствуйте, Светлана.
Чего-то вы там перемудрили с макросами, никаких макросов добавлять не надо было.
Откройте прикреплённый к статье файл, и скопируйте весь код (функции) в стандартный модуль вашей личной книги макросов.
После этого, в любом открытом у вас файле Excel, будет доступна функция склонения, которую будете вводить в виде формулы в ячейки.
Никаких дополнительных макросов писать на надо.
А чтобы не было циклических ссылок - формула должна ссылаться на другую ячейку (где исходное ФИО), а не на саму себя

Здравствуйте!
Добавила макрос, вставляю функцию, выбираю ячейку с ФИО (в окне функции склоняет всё верно), нажимаю ОК и появляется предупреждение о циклической ссылке, затем в этой ячейке появляется "0". В чем может быть ошибка?
Еще при создании макроса открывается окно вот с этим:
Sub СклонениеФИО()
'
' СклонениеФИО Макрос
'
' Сочетание клавиш: Ctrl+т
'
End Sub
После этого я вставляю код для склонения ФИО, но программа ругается, как я понимаю, что после "END" ничего быть не должно. Что делать с этими SUB? Хотелось бы сохранить это имя в списке макросов.

Здравствуйте. Владимир
Функция не склоняет ФИО, если имя отчество написаны не полностью, а инициалами (т.к. по отчеству определяется пол)

Здравствуйте!
Подскажите пожалуйста "чайнику", что надо подправить в коде, чтоб склонялась только фамилия, а инициалы и всё что за ними в том числе и латиница, символы, оставались неизменными? Например: Сидоров А.С. гр. IV - Сидорову А.С гр. IV. Спасибо!

Владимир, а вы не пробовали просто скачать и открыть прикреплённый к статье файл с примером?

Про то, что такое макросы, и как ими пользоваться, - много написано в интернете.
Макросы не требуют установки)
Чтобы использовать макрос во всех своих файлах - его надо скопировать в личную книгу макросов.
(кк это сделать - найдете в инете инструкцию)

а как этот волшебный макрос установить на мой exel, с учетом того что я полный чайник

Спасибо дорогой друг!!!! Все сделал! Вы правы... не то скопировал...вообщем все работает просто супер!!!!! Спасибо Вам за помощь!!!!! Огромное Вам человеческое спасибо!!!! И пусть у Вас все будет хорошо в жизни!!!!!

Геннадий, а где вы нашли такую строку в моём макросе?
Если вы там что-то поменяли в коде, - ко мне какие вопросы...

Вставьте функцию в СТАНДАРТНЫЙ МОДУЛЬ (не в модуль листа или книги),
и напишите в ячейку формулу (вручную, или программно)
Не надо править код функции, если хотите, чтобы все работало...

s = Split(Application.Trim(.Value)) пишет что вот здесь ошибка...

Спасибо... но почему то выходит ошибка... (( А в данном случае код надо поместить в книгу? или на лист?

Зачем что-то делать в коде?

на листе2, в ячейке D12, напишите формулу типа =DativeCase(Лист1!B20)
и всё будет работать

Добрый день! Отличный макрос! А подскажите, что нужно изменить чтобы исходные Ф.И.О. брались в одной ячейке (например B20) Лист1 (ручной ввод, а результат в дательном падеже появлялся в конкретной ячеке (например D12) на Листе2? Как это сделать в коде? Помогите...пожалуйста....

посмотрите на последнее слово в заголовке функции:

Function DativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String

As String - значит, возвращает строку текста

Какой тип данных возвращает функция? Стоку или другое?

спасибо большое за отличный макрос! всех благ!

Большое спасибо! Эта функция сэкономила мне уйму времени!
ПС. Функция дательного падежа для ФИО на русскому работает без проблем (проверено на 50 записях).

Русские ФИО склоняет очень хорошо. украинские фамилии склоняет тоже нормально, а вот имена и отчества очень плохо.
Для теста отправляю Вам парочку примеров:
КОЙДЮК МАРІЯ ІВАНІВНА - Койдюк Маріе Іванівне
ПОЛІНКІНА ГАННА ОЛЕКСАНДРІВНА - Полінкіной Ганне Олександрівне
СЕРГІЄНКО ВІКТОРІЯ ОЛЕКСАНДРІВНА - Сергієнко Вікторіе Олександрівне

Здравствуйте, Андрей.
Насколько мне известно, функция справляется с большинством украинских ФИО
Есть, наверняка, сложности со склонением некоторых ФИО, - но вряд ли можно утверждать, что функция вообще не подходит для этой задачи...

Добрый день! Подскажите пожалуйста а есть ли перевод украинских фамилий, имён и отчеств в дательный падеж? А то эта функция для такой задачи не подходит. Заранее спасибо!

Творительного нет. Есть только родительный и дательный.
Если надо, - могу сделать (не бесплатно)

Неплохо. А есть творительный падеж? Мне надо именно творительный падеж.

Сделал аналогичную UDF функцию для родительного падежа:
http://excelvba.ru/code/GenitiveCase

К обеим статьям прикрепил обновлённый файл - теперь, на тестовых данных,
обе функции не дают ни единой ошибки.

Отлично!!! Спасибо, с удовольствием забираю! ;))

Владимир, спасибо за замечания.
Внёс исправления в код (в статье, и прикреплённом файле)

На книгу у меня времени нет, - код можно усложнять до бесконечности (вспомните, например, фамилии и имена-исключения, иностранные фамилии, и т.д.)
Всего, в любом случае, не предусмотришь.

Моей целью было сделать функцию, которая в подавляющем большинстве случаев давала бы верный ответ
(я теперь встроил эту функцию в свою программу заполнения документов)

Вроде бы, с этой задачей я справился)

Здравствуйте, Игорь! Спасибо за интересный сайт! Несколько замечаний:
1. Женские отчества могут оканчиваться на "чна" (Ильинична)
2. Не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю, а также на -а с предшествующей гласной (Ваш список не полный).
3. Если мужской фамилии, оканчивающейся на -ец, предшествует гласная (Бугаец), то эта гласная не должна выпадать при склонении.

Может быть, Вам будет интересна книга Л.П.Калакуцкой "Склонение фамилий и личных имен в русском литературном языке" (могу прислать в pdf-формате).

Уведомляю, что стала доступна новая версия функции для склонения в дательный падеж.

Код функции заметно переработан (и усложнён).

Основные изменения:

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

 

Во вложении к статье - тестовый файл, где есть результаты склонения новой функцией (всего 3 ошибки на 177 ФИО),
результат использования прежней функции datelny, с вариантами от МСН, Марии и Светланы (соответственно, 44, 42 и 49 ошибок на 177 ФИО),
а также аналогичная функция от KrukVN (23 ошибки на 177 ФИО)

 

PS: В ближайшее время, постараюсь аналогично доработать функцию для склонения в родительный падеж.

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

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

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

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

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

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

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

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

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

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