Страницы: 1
RSS
Перевести имена из винительного в именительный падеж, Перевести имена из винительного в именительный падеж
 
Доброго времени суток.
Огромная просьба помочь: есть таблица, в которой имена сотрудников в винительном падеже, нужно их перевести в именительный падеж.
Заранее бооольшое спасибо)
 
сложно это очень
если перевод именительный -> винительный несложен (макрос есть у меня на сайте),
то обратно - все сложнее (несколько разных фамилий в винительном падеже могут выглядеть одинаково - и никак не угадать, какой из 2-3 вариантов фамилии был изначально)
 
Сами пробовали что-нибудь сделать?

Возьмите за основу мою UDF-функцию для перевода именительный-винительный,
и сделайте по аналогии, на наоборот:

Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
Function AccusativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
    ' Функция формирует ВИНИТЕЛЬНЫЙ падеж из ФИО
    ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество
    ' © 2015 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) & "уя"
                    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
        AccusativeCase = Join(arrSurname, "-") & " "        ' соединяем части склоняемой фамилии обратно в одну строку
    End If
 
    If Len(sName) > 0 Then        '   Имя
        NameException$ = GetAccusativeException(sName)
        If Len(NameException$) Then        ' для имен-исключений
            AccusativeCase = AccusativeCase & NameException$
        Else        ' имя не найдено в списке исключений
            If bMaleSex Then
                Select Case Right(sName, 1)
                    Case "й", "ь": AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) & "я"
                    Case "а": AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) & "у"
                    Case "я": AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) & "ю"
                    Case "о", "и": AccusativeCase = AccusativeCase & sName
                    Case Else: AccusativeCase = AccusativeCase & sName & "а"
                End Select
            Else
                Select Case Right(sName, 1)
                    Case "а": AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) & "у"
                    Case "я": AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) & "ю"
                    Case Else: AccusativeCase = AccusativeCase & sName
                End Select
            End If
        End If
        AccusativeCase = AccusativeCase & " "
    End If
 
    If Len(sPatronymic) > 0 Then        '   Отчество
        If Right(sPatronymic, 4) = "оглы" Or Right(sPatronymic, 4) = "кызы" Then
            AccusativeCase = AccusativeCase & sPatronymic
        Else
            If bMaleSex Then
                AccusativeCase = AccusativeCase & sPatronymic & "а"
            Else
                AccusativeCase = AccusativeCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "у"
            End If
        End If
    End If
    AccusativeCase = Replace(AccusativeCase, "-", "- ")
    AccusativeCase = StrConv(AccusativeCase, vbUnicode + vbProperCase)
    AccusativeCase = Trim(Replace(AccusativeCase, "- ", "-"))
End Function
 
Function GetAccusativeException(ByVal txt$) As String        ' склонение имён-исключений
    Select Case txt$
        Case "Павел": GetAccusativeException = "Павла"
        Case "Лев": GetAccusativeException = "Льва"
        Case "Пётр": GetAccusativeException = "Петра"
            ' Case "Любовь": GetAccusativeException = "Любови"
 
            ' без изменения (не склоняются) - перечисляем через запятую
            ' Case "Али", "Бали": GetAccusativeException = txt$
    End Select
End Function
 
Есть ли возможность писать фамилии заглавными буквами, в столбце В получилось, а в столбцах С и D нет.
 
А заглавные в каком падеже?
 
Заменил в VBA буквы фамилий заглавными. В дательном работает. А в  родительном и в винительном нет. Не могу понять почему.
Страницы: 1
Читают тему
Наверх
Loading...