Новости:

К первому сообщению темы должен быть прикреплен файл примера в формате xls*.
Приложив пример, Вы избавите себя и других от вопросов типа "А какой критерий?", "А куда выводить результат?", "А сколько строк?" и все тех же просьб выложить файл. Рисовать за Вас Ваши же таблички с заданиями, а затем и решение к ним, никто желанием не горит. Да и, как показывает практика, в большинстве случаев без файла решения не найти.

Главное меню

Изменение окончания слов в ячейке

Автор S3m, 03.04.2012, 22:24

« назад - далее »

S3m

Вечер добрый! Подскажи пожалуйста советом!
Есть ячейка в ней указано ФИО например "Иванов Иван Иваныч", дайте совет пожалуйста как можно сделать так чтобы в данной ячейке ФИО "Иванов Иван Иваныч" поменяло окончание на например "Ивану Ивану Иванычу" ?
Заранее спасиба!

Serge 007

Цитата: S3m от 03.04.2012, 22:24
...как сделать так чтобы в данной ячейке ФИО "Иванов Иван Иваныч" поменяло окончание на например "Ивану Ивану Иванычу" ?
В этой же ячейке - только макросом, в соседней - можно формулой:
=ПОДСТАВИТЬ(A1&" ";" ";"у ")
Бесплатная помощь: www.excelworld.ru
Платная помощь: sergeyizotov@excelworld.ru
Ю-money: 41001419691823 | WMR:126292472390

MCH


S3m

Спасиба за помощь, нашлось очень классное решение :

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

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

Код функции DativeCase:

Function DativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
    ' Функция формирует дательный падеж из ФИО
   ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество

    Application.Volatile True
    On Error Resume Next
    If sName$ = "" And sPatronymic$ = "" Then
        arr = Split(Application.Trim(sSurname$))
        sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = arr(2)
    End If

    Dim bMaleSex As Boolean: bMaleSex = (Right(sPatronymic, 1) = "ч")

    If Len(sSurname) > 0 Then    '   Фамилия
       If bMaleSex Then
            Select Case Right(sSurname, 1)
                Case "о", "и", "я", "а": DativeCase = sSurname
                Case "й": DativeCase = Mid(sSurname, 1, Len(sSurname) - 2) + "ому"
                Case Else: DativeCase = sSurname + "у"
            End Select
        Else
            Select Case Right(sSurname, 1)
                Case "о", "и", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _
                     "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь": DativeCase = sSurname
                Case "я": DativeCase = Mid(sSurname, 1, Len(sSurname) - 2) & "ой"
                Case Else: DativeCase = Mid(sSurname, 1, Len(sSurname) - 1) & "ой"
            End Select
        End If
        DativeCase = DativeCase & " "
    End If

    If Len(sName) > 0 Then    '   Имя
       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 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
        DativeCase = DativeCase & " "
    End If

    If Len(sPatronymic) > 0 Then    '   Отчество
       If bMaleSex Then
            DativeCase = DativeCase & sPatronymic & "у"
        Else
            DativeCase = DativeCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "е"
        End If
    End If
End Function

Но я к сожалению не понял, как можно данную функцию применить на диапазон строк например A10:A20

MCH

Вы примеры по ссылке открывали? там есть варианты использования, макросы должны быть разрешены

MCH

Вариант использования

S3m

Уважаемый MCH!
посмотрите пожалуйста на приложенный к данному сообщению пример, в нём я использовал данные вами примеры (DativeCase)
Но пока что в пределах 1й ячейки, при попытке передать диапазон в переменную FIO и использовать на диапазоне функцию ПереводФИО выдаётся ошибка.
Подскажите в чем ошибка.. ?

S3m

Диапазон ячеек

Wasilic

Так попробуйте
Sub переводФИО()
    For I = 1 To Range("A" & Rows.Count).End(xlUp).Row
        Cells(I, 1) = DativeCase(Cells(I, 1))
    Next
End Sub
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.

S3m

Спасибо!
Поэкспериментировал с кодом, чтобы он мог выполняться на других листах и в других диапазонах ячеек, посмотрите пожалуйста что получилось.  На других листах он стал выполняться, но выбрать другой диапазон не получается. Опять где то косяк  :-\

Sub Fio()
   For I = 3 To Range("C" & Rows.Count).End(xlUp).Row
   With Sheets("Лист2").Select
       Cells(I, 1) = DativeCase(Cells(I, 1))
       End With
   Next
 
End Sub

Wasilic

#10
Cells(1, 1) это  Ячейка(строка 1,столбец 1)
В коде, строка заменена переменной "I" а столбец указан конкретно = "1"
Что надо поменять в Вашем случае? Правильно, № столбца!
Cells(I, 3) = DativeCase(Cells(I, 3))
Или, так будет понятней!?
Range("C" & I)= DativeCase(Range("C" & I))

Кроме того в коде последнего примера лишнее:

Sub Fio()
  For I = 3 To Range("C" & Rows.Count).End(xlUp).Row
    With Sheets("Лист2").Select   
        Cells(I, 3) = DativeCase(Cells(I, 3))
        End With
  Next
End Sub
Может и я на что сгожусь ... Если сгодился, можете меня по+благодарить+.

MCH

S3m, а Вам пример в виде функции, реализованный в файле datelny_padeg2.xls не нравится?
на мой взгляд, данный вариант значительно легче использовать

S3m

#12
Добрый день всем, спасиба за помощь и советы!
MCH ,  пытался использовать, но он странный как функция он работает без проблем, но если использовать его в макросе

   For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
   With Sheets("Лист_зачисления").Range("a10:b" & 8 + KS).Select
       Cells(i, 2) = datelny(Cells(i, 2))
       End With
   Next

он выдает ошибку,  invalid rocedure call or argument.

в прикреплённом ниже примере данный скрипт выполняется при нажатии кнопки выполнить перенос.

PS: на остальной код не сильно обращайте внимания  :-[   :P   до программиста мне  пока далеко и там куча косяпоров =)