На главную
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! Организуем VBA-FAQ! Если у Вас есть предложения, выскажитесь здесь: Пишем FAQ, интересно Ваше мнение
Популярные разделы FAQ:    user posted image Общие вопросы    user posted image Особенности VBA-кода    user posted image Оптимизация VBA-кода    user posted image Полезные ссылки

1. Старайтесь при создании темы указывать в заголовке или теле сообщения название офисного приложения и (желательно при работе с Office 95/97/2000) его версию. Это значительно сократит количество промежуточных вопросов.
2. Формулируйте вопросы как можно конкретнее, вспоминая (хотя бы иногда) о правилах ВЕЛИКОГО И МОГУЧЕГО РУССКОГО ЯЗЫКА, и не забывая, что краткость - сестра таланта.
3. Не забывайте использовать теги [сode=vba] ...текст программы... [/code] для выделения текста программы подсветкой!
4. Темы с просьбой выполнить какую-либо работу полностью за автора здесь не обсуждаются и переносятся в раздел ПОМОЩЬ СТУДЕНТАМ.
Модераторы: Old Bat, MIF
  
> Помогите разобраться с макросом и сохранении значений работы в книге Excel, Не сохраняются значения в таблице после открытия документа на другом ПК
Доброго времени суток всем.

В VBA я не силен, и не знаю многих моментов. Порошу помочь всех гуру VBA.
Собственно задача стоит такая: есть макрос сохранёный в файле .xla в папке %UserProfile%\AppData\Roaming\Microsoft\AddIns
Код модуля:
ExpandedWrap disabled
    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)?
Сообщение отредактировано: User32 -
Незнание некоторых фактов сполна компенсируется знанием некоторых принципов...
Нужно просто поместить функцию в файл. Откройте редактор VBA, создайте модуль (простой, не класса), и вставьте в него текст функции. Файл сохраняйте как XLSM.
Есть претензии ко мне как к модератору? читайте Правила, разделы 5 и 6, и действуйте соответственно.
Есть претензии ко мне как к участнику? да ради бога.
Не нравятся мои ответы? не читайте их.
В общем, берегите себя. Нервные клетки не восстанавливаются.
Цитата Akina @

Ну это самое простое решение, но в том то и дело, что нельзя передавать документ с макросами.
И задача поставлена так чтобы реализовать это через файл подключаемого модуля (надстройки).
Незнание некоторых фактов сполна компенсируется знанием некоторых принципов...
Тогда перед отправкой заменять формулы на значения.
Хотите - вручную каждый раз, хотите напишите функцию (можно в другом файле), которая будет обращаться к нужному файлу и заменять.
Можно ограничиться определённым диапазоном. Можно вообще все формулы в значения.
ExpandedWrap disabled
        For Each sh In ActiveWorkbook.Worksheets
            sh.UsedRange.Value = sh.UsedRange.Value
        Next sh
Сообщение отредактировано: yurpas -
Пока желания выше возможностей, у человека есть цель
Цитата User32 @
нельзя передавать документ с макросами.
И задача поставлена так чтобы реализовать это через файл подключаемого модуля (надстройки).

Файл с модулем нельзя, а надстройку можно? странно как-то...
Но если так - то какая разница, передавать надстройку или .XLA c функцией? Один хрен что-то макрососодержащее передавать придётся.
Есть претензии ко мне как к модератору? читайте Правила, разделы 5 и 6, и действуйте соответственно.
Есть претензии ко мне как к участнику? да ради бога.
Не нравятся мои ответы? не читайте их.
В общем, берегите себя. Нервные клетки не восстанавливаются.
Цитата Akina @
Цитата User32 @
нельзя передавать документ с макросами.
И задача поставлена так чтобы реализовать это через файл подключаемого модуля (надстройки).

Файл с модулем нельзя, а надстройку можно? странно как-то...
Но если так - то какая разница, передавать надстройку или .XLA c функцией? Один хрен что-то макрососодержащее передавать придётся.

Я и не говорил о передаче файла с надстройками. Файл надстроек это некая библиотека функций которая доступна и подключается всем пользователям в рамках их отдела и не должна передаваться в сторонние организации и другим людям.

Добавлено
Цитата yurpas @
Тогда перед отправкой заменять формулы на значения.
Хотите - вручную каждый раз, хотите напишите функцию (можно в другом файле), которая будет обращаться к нужному файлу и заменять.
Можно ограничиться определённым диапазоном. Можно вообще все формулы в значения.
ExpandedWrap disabled
        For Each sh In ActiveWorkbook.Worksheets
            sh.UsedRange.Value = sh.UsedRange.Value
        Next sh

А на "лету" как то можно это реализовать? Ну в смысле, как только пользователь ввел формулу с значениями и функция естественно вернула результат то заменяем формулу в ячейки на заначение что было возвращено этой формулой.
Незнание некоторых фактов сполна компенсируется знанием некоторых принципов...
Цитата User32 @
Я и не говорил о передаче файла с надстройками. Файл надстроек это некая библиотека функций которая доступна и подключается всем пользователям в рамках их отдела и не должна передаваться в сторонние организации и другим людям.

Эммм? в смысле - нужно избежать ошибок именно у этих сторонних людей и организаций, которым сей код передаваться не должен, и передаётся только файл данных? тогда да, yurpas прав.
Сообщение отредактировано: Akina -
Есть претензии ко мне как к модератору? читайте Правила, разделы 5 и 6, и действуйте соответственно.
Есть претензии ко мне как к участнику? да ради бога.
Не нравятся мои ответы? не читайте их.
В общем, берегите себя. Нервные клетки не восстанавливаются.
Цитата User32 @
А на "лету" как то можно это реализовать? Ну в смысле, как только пользователь ввел формулу с значениями и функция естественно вернула результат то заменяем формулу в ячейки на заначение что было возвращено этой формулой.

Хороший вопрос. Никогда не создавал собственные формулы. Попробуйте. Наверное логичнее тогда в пределах отдела в надстройку впихнуть сочетание клавиш, которое станет общепринятым для отдела. И будет работать только если активная ячейка содержит нужные данные (и/или активная ячейка принадлежит нужному диапазону) и рассчитывать значение для соседней ячейки.
Пока желания выше возможностей, у человека есть цель
1 пользователей читают эту тему (1 гостей и 0 скрытых пользователей)
0 пользователей:


Рейтинг@Mail.ru
[ Script Execution time: 0,1213 ]   [ 20 queries used ]   [ Generated: 8.08.20, 03:25 GMT ]