Фамилия и инициалы из ФИО - функция VBA

Результат работы VBA-функции Инициалы

Функция получает в качестве параметра текстовую строку с виде "Фамилия имя отчество", и обрезает имя и отчество, оставляя лишь инициалы - в виде "Фамилия И. О."

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

Автор функции: Андрей Энтелис

Описание особенностей функции - на форуме: programmersforum.ru/showpost.php?p=757147&postcount=6

...не существует точного формального алгоритма разделения ФИО на части.
Отделить фамилию от имени формально нельзя, не зная генеалогии и языка носителя. Можно только воспользоваться разнообразными эвристиками.

Кроме того, разные органы (в разное время) придерживались (-ются) разных взглядов на то как в том или ином случае должны выглядеть инициалы.
Одно дело документы УФМС - другое, регистраторы ЦБ, третье - оформление коммерческих документов.
Так, часть служб требует что бы 2-3 сложные короткие имена Юго-Восточной Азии не сокращались. А часть нет.

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

У многих возможно возникает вопрос: А откуда берётся весь этот зоопарк и зачем это всё нужно? Как правило, все эти Доны Педро - иностранные граждане получающие Российский паспорт на основании ранее выданных вне юрисдикции РФ документов. Ситуации правовые бывают разные. И достаточно часто в новый Российский паспорт пишется вариант транслитерации на кириллицу с языка носителя.
Российские паспорта с -оглы и -кызы выдаются сейчас в Татарстане. Мне встретился клиент которого по паспорту 2007 г. звали Мустафа Олег оглы...

Option Compare Text
 
Public Function Инициалы(s As String, Optional ToLeft As Boolean = False)
 
    Dim sv As Variant, sФ As String, sИ As String, sО As String, i As Long, k As Long
    Application.Volatile True
 
    If InStr(s, ".") > 0 Or Len(Trim$(s)) = 0 Then
        Инициалы = s    'Инициалы заданы явно или пустая строка
        Exit Function
    End If
    'Нормализация входной строки
    s = Replace(Application.Trim(s), Chr(30), "-")
    s = Replace(Replace(s, " -", "-"), "- ", "-")
    s = Replace(Replace(s, "' ", "'"), " '", "'")    ' О 'Генри Александр; О' Генри Александр; Н' Гомо; Д' Тревиль

    sv = Split(s)
    sИ = vbNullString: sО = vbNullString: sФ = vbNullString
 
    i = UBound(sv)
    If i < 1 Then Инициалы = s: Exit Function
 
    Select Case sv(i)
        Case "оглы", "кызы", "заде"
            'бей, бек, заде, зуль, ибн, кызы, оглы, оль, паша, уль, хан, шах, эд, эль
            i = i - 1
            sО = UCase(Left$(sv(i), 1)) & "."
            i = i - 1
        Case "паша", "хан", "шах", "шейх"
            i = i - 1
        Case Else
            Select Case Right$(sv(i), 3)
                Case "вич", "вна"
                    If i >= 2 Then    'Стандартное окончание русских отчеств
                        sО = СropWord(sv(i))
                    Else           'Имя типа Босан Славич
                        sИ = СropWord(sv(i)): sФ = sv(0)
                    End If
                    i = i - 1
                Case Else
                    k = InStr(sv(i), "-")
                    If k > 0 Then
                        Select Case Mid$(sv(i), k + 1)
                            Case "оглы", "кызы", "заде", "угли", "уулы", "оол"
                                'Вариант насаба «-оглы» и «-заде»  типа Махмуд-оглы
                                sО = UCase(Left$(sv(i), 1)) & "."
                                i = i - 1
                                If i = 0 Then
                                    sИ = sО
                                    sО = vbNullString
                                End If
                        End Select
                    ElseIf i > 2 Then
                        Select Case sv(i - 1)
                            Case "ибн", "бен", "бин"
                                sО = UCase(Left$(sv(i), 1)) & "."    ' Усерталь Алишер бен Сулейман
                                i = i - 2
                        End Select
                    Else    ' Бен Эдуард
                        sИ = UCase(Left$(sv(i), 1))
                        If Len(sv(i)) > 1 Then sИ = sИ & "."
                        i = i - 1
                    End If
            End Select
    End Select
 
    Select Case sv(0)
        Case "де", "дел", "дос", "cент", "ван", "фон", "цу"
            If i >= 2 Then
                sФ = sv(0) & " " & StrConv(sv(1), vbProperCase)
                sИ = СropWord(sv(2))
            Else   'Де Николай
                If Len(sИ) > 0 Then
                    sФ = sv(0) & " " & StrConv(sv(1), vbProperCase)
                Else
                    sФ = StrConv(sv(0), vbProperCase): sИ = СropWord(sv(1))
                End If
            End If
        Case Else
            If Len(sФ) = 0 Then    'Ещё не определили фамилию
                sФ = StrConv(sv(0), vbProperCase)
                If Len(sИ) = 0 Then sИ = СropWord(sv(1))
            End If
    End Select
    If ToLeft Then Инициалы = sИ & sО & " " & sФ Else Инициалы = sФ & " " & sИ & sО
End Function
 
Public Function СropWord(s As Variant) As String
    If Len(s) = 1 Then
        СropWord = s
    Else
        ss$ = UCase(Left$(s, 1)) & ".": k = InStr(s, "-")
        If k > 0 Then ss$ = ss$ & "-" & Mid$(s, k + 1, 1) & "."
        СropWord = ss$
    End If
End Function

Вложения:
CropFIO.xls50.5 КБ

Комментарии

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

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

СПАСИБО!

Спасибо ОГРОМНОЕ! Реально выручил!!!!!!

Сам же и ответил )))
Дописать 33-ю строку окончаниями отчеств в разных падежах
"...
Case "вич", "вна", "ной", "чем", "ича", "ичу", "вны", "вне"
..."

Не работает если полное ФИО написано в падеже отличном от именительного?

Poltava, спасибо за замечание. Исправил код в тексте статьи.

Доброго времени суток. Спасибо за отличный сайт. Обнаружил что функция не переставляет инициалы в лево! Посмотрев внимательно увидел что в вызове фанкции аргумент "Cлева" начинаеться с английской "C" а в коде используеться кирилическая "C" может кому то пригодиться мое наблюдение!

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

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

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

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