На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА 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.
        Цитата Akina @

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

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

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

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

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

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

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

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


                  Рейтинг@Mail.ru
                  [ Script execution time: 0,0331 ]   [ 16 queries used ]   [ Generated: 29.03.24, 02:14 GMT ]