Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
VBA не учитывает исключения
 
Не получается учесть фамилии-исключения в функции ReplaceSurname. Должна быть в цикле женской фамилии в начале проверка на исключение, а затем уже склонение. Но там где надо поставить  исключение выводится пробел.


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              

          Else    ' женские фамилии
                SurException$ = ReplaceSurname(sSurnamePart)
                If Len(SurException$) Then    ' для фамилий-исключений
                   DativeCase = DativeCase & SurException$
                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
           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 = "Бибигули"
       Case "Гузель": GetDativeException = "Гузели"
       Case "Анаргуль": GetDativeException = "Анаргули"
       Case "Алия": GetDativeException = "Алии"
       Case "Галия": GetDativeException = "Галии"
       Case "Альфия": GetDativeException = "Альфии"
           
           ' без изменения (не склоняются) - перечисляем через запятую
       Case "Али", "Бали": GetDativeException = txt$
   End Select
End Function

Function ReplaceSurname(ByVal surname As String) As String
   Select Case surname
       Case "Дербнавы": ReplaceSurname = "Дербнавывпфв" ' пример исключения
       ' Добавьте другие исключения здесь
       Case Else: ReplaceSurname = "" ' возвращает оригинальную фамилию, если она не найдена в списке исключений
   End Select
End Function
Удаление и замена части текста по условиям списка
 
Разумно
Удаление и замена части текста по условиям списка
 
Пользователи вводят адрес с разными обозначениями дома, корпуса и квартиры.

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

Например вводят "Кор.3", "корпус 3", "кр 3", просто "3".

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

Таже ситуация с обозначением дома, квартиры.
Страницы: 1
Loading...