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

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

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

 

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

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

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

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

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

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

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

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

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

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

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

Function GenitiveCase(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) - 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) & "уя"
                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 = txt$
    End Select
End Function

ВложениеРазмерЗагрузкиПоследняя загрузка
Dative_and_Genitive_Case.zip - склонение в родительный и дательный падеж на VBA72.28 КБ73 года 32 недели назад

Комментарии

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

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

Здравствуйте, Максим
Макрос предназначен только для ФИО - с прочими словами и фразами он работает некорректно

Чтобы регистр не изменялся, - удалите в макросе эту строку:

GenitiveCase = StrConv(GenitiveCase, vbProperCase)

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

Спасибо за ответ, но у меня в таблице только фамилии с инициалами.

Если только фамилия нужна в родительном падеже, - то после склонения ФИО, при помощи формулы, оставьте только первое слово (текст до пробела)
В коде ничего менять не нужно.

Если в исходных данных - только фамилия (без имени-отчества), функция работать не будет, т.к. невозможно только по фамилии определить пол, а некоторые фамилии по-разному склоняются в зависимости от пола.
Пример - фамилии типа Лебедь, Головач, и т.д.
Если такая фамилия принадлежит женщине, - то она при склонении не меняется (а мужская - изменяется)

Если только фамилию нужно склонять, то что нужно обрезать?

А такое распространенное имя как Ольга в родительный падеж неправильно склоняет :-(

Я имел ввиду исключение склонения иностранных имён, оканчивающихся на "е" и "и".
У себя то я дописал.

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

А что мешает вам самостоятельно доработать код?

Это же очень просто, - надо взять строку

Case "Павел": GetGenitiveException = "Павла"

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

Кто-нибудь допилил скрипт? Не все правила для имён в мужском роде прописаны.

Огромное спасибо!
именно то что было нужно

Нет у меня такой функции. Была бы, — дал бы вам ссылку.
Сделать могу, но не бесплатно (много исключений, долго возиться с кодом)

так я не умею, поэтому и обращаюсь к специалистам в этом деле

Можно. Делайте.
Как сделаете — скиньте мне, я на сайте выложу.

А можно такой же файлик, только ещё с винительным падежом?
Чтобы три столбика подряд?

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

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

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

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