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

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