Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[18.119.167.196] |
|
Сообщ.
#1
,
|
|
|
Доброго времени суток всем.
В VBA я не силен, и не знаю многих моментов. Порошу помочь всех гуру VBA. Собственно задача стоит такая: есть макрос сохранёный в файле .xla в папке %UserProfile%\AppData\Roaming\Microsoft\AddIns Код модуля: Attribute VB_Name = "Module1" Dim Chr(32) As String Option Compare Text ' эта строка нужна обязательно! (сравнение без учёта регистра) Private Function DativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String ' Функция формирует дательный падеж из ФИО ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество 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 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) & "ому" 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) & "ую" End Select 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 ' не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю, ' а также на -а с предшествующей гласной 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 Private 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 = "Валерии" Case "Любов": GetDativeException = "Любови" ' без изменения (не склоняются) - перечисляем через запятую Case "Али", "Бали": GetDativeException = txt$ End Select End Function Function ДательныйФИО(FIO$) As String ' возвращаем пустую строку при нулевом аргументе If ДательныйФИО = "" Then ДательныйФИО = Chr(32) End If ДательныйФИО = DativeCase(FIO$) End Function В Екселе мы добавляем Параметры Excel -> Надстройки ... И в новых документах можем вызывать пользовательские функции. В ячейке A1 пропишем Ф.И.О. - Иванов Иван Иванович, а в ячейку B1 нашу функцию =ДательныйФИО(A1) получим результат Иванову Ивану Ивановичу Ивсе хорошо, но стоит только сохранить файл и открыть на другом ПК где нет нашей условной библиотеки функций то вместо результата будет ссылка на наш файл и функцию а не полученый результат - Иванову Ивану Ивановичу. Как сохранять результат чтобы он был доступен на любом ПК без нашей условной библиотеки функций (файла .xla)? |
Сообщ.
#2
,
|
|
|
Нужно просто поместить функцию в файл. Откройте редактор VBA, создайте модуль (простой, не класса), и вставьте в него текст функции. Файл сохраняйте как XLSM.
|
Сообщ.
#3
,
|
|
|
Цитата Akina @ Ну это самое простое решение, но в том то и дело, что нельзя передавать документ с макросами. И задача поставлена так чтобы реализовать это через файл подключаемого модуля (надстройки). |
Сообщ.
#4
,
|
|
|
Тогда перед отправкой заменять формулы на значения.
Хотите - вручную каждый раз, хотите напишите функцию (можно в другом файле), которая будет обращаться к нужному файлу и заменять. Можно ограничиться определённым диапазоном. Можно вообще все формулы в значения. For Each sh In ActiveWorkbook.Worksheets sh.UsedRange.Value = sh.UsedRange.Value Next sh |
Сообщ.
#5
,
|
|
|
Цитата User32 @ нельзя передавать документ с макросами. И задача поставлена так чтобы реализовать это через файл подключаемого модуля (надстройки). Файл с модулем нельзя, а надстройку можно? странно как-то... Но если так - то какая разница, передавать надстройку или .XLA c функцией? Один хрен что-то макрососодержащее передавать придётся. |
Сообщ.
#6
,
|
|
|
Цитата Akina @ Цитата User32 @ нельзя передавать документ с макросами. И задача поставлена так чтобы реализовать это через файл подключаемого модуля (надстройки). Файл с модулем нельзя, а надстройку можно? странно как-то... Но если так - то какая разница, передавать надстройку или .XLA c функцией? Один хрен что-то макрососодержащее передавать придётся. Я и не говорил о передаче файла с надстройками. Файл надстроек это некая библиотека функций которая доступна и подключается всем пользователям в рамках их отдела и не должна передаваться в сторонние организации и другим людям. Добавлено Цитата yurpas @ Тогда перед отправкой заменять формулы на значения. Хотите - вручную каждый раз, хотите напишите функцию (можно в другом файле), которая будет обращаться к нужному файлу и заменять. Можно ограничиться определённым диапазоном. Можно вообще все формулы в значения. For Each sh In ActiveWorkbook.Worksheets sh.UsedRange.Value = sh.UsedRange.Value Next sh А на "лету" как то можно это реализовать? Ну в смысле, как только пользователь ввел формулу с значениями и функция естественно вернула результат то заменяем формулу в ячейки на заначение что было возвращено этой формулой. |
Сообщ.
#7
,
|
|
|
Цитата User32 @ Я и не говорил о передаче файла с надстройками. Файл надстроек это некая библиотека функций которая доступна и подключается всем пользователям в рамках их отдела и не должна передаваться в сторонние организации и другим людям. Эммм? в смысле - нужно избежать ошибок именно у этих сторонних людей и организаций, которым сей код передаваться не должен, и передаётся только файл данных? тогда да, yurpas прав. |
Сообщ.
#8
,
|
|
|
Цитата User32 @ А на "лету" как то можно это реализовать? Ну в смысле, как только пользователь ввел формулу с значениями и функция естественно вернула результат то заменяем формулу в ячейки на заначение что было возвращено этой формулой. Хороший вопрос. Никогда не создавал собственные формулы. Попробуйте. Наверное логичнее тогда в пределах отдела в надстройку впихнуть сочетание клавиш, которое станет общепринятым для отдела. И будет работать только если активная ячейка содержит нужные данные (и/или активная ячейка принадлежит нужному диапазону) и рассчитывать значение для соседней ячейки. |