Хитрости »
Основные понятия (23)
Сводные таблицы и анализ данных (9)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (14)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (63)
Разное (38)
Баги и глюки Excel (2)

Как добавить код процедуры программно, скопировать модуль

Бывают ситуации, когда кодом создается книга, в нее опять же кодом заносятся данные. И порой необходимо помимо всего прочего добавить в новую книгу и код VBA. Естественно, тоже программно. На самом деле это совсем не сложно.

Для изменения кодов программно необходимо, чтобы было проставлено доверие к объектной модели проекта VBA и изменяемый проект не должен быть защищен. Подробнее читайте в статье: [[Что необходимо для внесения изменений в проект VBA(макросы) программно]]
Без этого будет невозможно программное вмешательство в проект VBA.

В данной статье я покажу как программно выполнить следующее:

Так же приведена функция, которая копирует указанный модуль из одной книги в другую.
Как копировать, экспортировать и импортировать модули вручную описано в этой статье


 
Теперь перейдем непосредственно к сути. Сначала рассмотрим добавление в проект стандартного модуля.
Для добавления стандартного модуля и кода в нем можно воспользоваться двумя методами:

  1. Экспорт имеющегося модуля(с процедурами) из книги с кодом в новую книгу. Чаще всего применяется когда кодов для записи в новую книгу довольно много и создавать их все, прописывая в коде, весьма неудобно и громоздко;
  2. Создание нового модуля и запись необходимых кодов в него. Применяется, если необходимо создать относительно короткие процедуры в модуле.


 
1. ЭКСПОРТ ИМЕЮЩЕГОСЯ МОДУЛЯ

Sub Copy_Module()
    Dim objVBProjFrom As Object, objVBProjTo As Object, objVBComp As Object
    Dim sModuleName As String, sFullName As String
    'расширение стандартного модуля
    Const sExt As String = ".bas"
 
    'имя модуля для копирования
    sModuleName = "Module1"
    On Error Resume Next
    'проект книги, из которой копируем модуль
    Set objVBProjFrom = ThisWorkbook.VBProject
    'необходимый компонент
    Set objVBComp = objVBProjFrom.VBComponents(sModuleName)
    'если указанного модуля не существует
    If objVBComp Is Nothing Then
        MsgBox "Модуль с именем '" & sModuleName & "' отсутствует в книге.", vbCritical, "Error"
        Exit Sub
    End If
    'проект книги для добавления модуля
    Set objVBProjTo = ActiveWorkbook.VBProject
    'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение
    sFullName = "C:\" & sModuleName & sExt
    objVBComp.Export Filename:=sFullName
    objVBProjTo.VBComponents.Import Filename:=sFullName
    'удаляем временный файл для импорта
    Kill sFullName
End Sub

Хочу добавить, что подобным образом можно копировать любой модуль. В конце статьи я приведу код функции, которая позволяет копировать любой компонент VBA из одной книги в другую.


 
2. СОЗДАНИЕ НОВОГО МОДУЛЯ

Sub Create_NewModule()
    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
    Dim sModuleName As String, sFullName As String
    Dim sProcLines As String
    Dim lLineNum As Long
 
    'добавляем новый стандартный модуль в активную книгу
    Set objVBComp = ActiveWorkbook.VBProject.VBComponents.Add(1)
    'получаем ссылку на коды модуля
    Set objCodeMod = objVBComp.CodeModule
    'узнаем количество строк в модуле
    '(т.к. VBA в зависимости от настроек может добавлять строки деклараций)
    lLineNum = objCodeMod.CountOfLines + 1
    'текст всставляемой процедуры
    sProcLines = "Sub Test()" & vbCrLf & _
        "    MsgBox ""Hello, World""" & vbCrLf & _
        "End Sub"
    'вставляем текст процедуры в тело нового модуля
    objCodeMod.InsertLines lLineNum, sProcLines
End Sub

Данная процедура добавит в активную книгу новый модуль и запишет в него процедуру:

Sub Test()
    MsgBox "Hello, World"
End Sub


 
 
CОЗДАНИЕ СОБЫТИЙНЫХ ПРОЦЕДУР
Помимо стандартных процедур, имеется возможность добавить и событийные(изменения на листе, открытие книги и т.п.). Я приведу примеры создания кода:

  • в Лист1 на изменении данных ячейки в новой книге
  • в ЭтаКнига(ThisWorkbook) на событие открытия книги.

На их основе уже можно будет понять как создать другие событийные процедуры.
 
CОЗДАНИЕ СОБЫТИЙНОЙ ПРОЦЕДУРЫ Worksheet_Change в Лист1

Sub CreateEventProcedure_WorkSheetChange()
    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
    Dim lLineNum As Long
    'добавляем новую книгу
    Workbooks.Add
    'получаем ссылку на проект и модуль листа
    Set objVBProj = ActiveWorkbook.VBProject
    Set objVBComp = objVBProj.VBComponents("Лист1")
    Set objCodeMod = objVBComp.CodeModule
    'вставляем код
    With objCodeMod
        lLineNum = .CreateEventProc("Change", "Worksheet")
        lLineNum = lLineNum + 1
        .InsertLines lLineNum, "    MsgBox ""Hello World"""
    End With
End Sub

Важно: для русской версии используется ссылка на Лист1. Для английской как правило Sheet1

Set objVBComp = objVBProj.VBComponents("Sheet1")

 
 
CОЗДАНИЕ СОБЫТИЙНОЙ ПРОЦЕДУРЫ Workbook_Open

Sub CreateEventProcedure()
    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
    Dim lLineNum As Long
    'добавляем новую книгу
    Workbooks.Add
    'получаем ссылку на проект и модуль книги
    Set objVBProj = ActiveWorkbook.VBProject
    Set objVBComp = objVBProj.VBComponents("ЭтаКнига")
    Set objCodeMod = objVBComp.CodeModule
    'вставляем код
    With objCodeMod
        lLineNum = .CreateEventProc("Open", "Workbook")
        lLineNum = lLineNum + 1
        .InsertLines lLineNum, "    MsgBox ""Hello World"""
    End With
End Sub

Важно: для русской версии используется ссылка на ЭтаКнига. Для английской ThisWorkbook

Set objVBComp = objVBProj.VBComponents("ThisWorkbook")

 
 
Функция CopyVBComponent
ПОЗВОЛЯЕТ КОПИРОВАТЬ ЛЮБОЙ КОМПОНЕНТ ИЗ ОДНОЙ КНИГИ В ДРУГУЮ

'---------------------------------------------------------------------------------------
' Procedure : CopyVBComponent
' DateTime  : 02.08.2013 23:10
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Функция копирует компонент из одной книги в другую.
'             Возвращает True, если копирование прошло удачно
'             False - если компонент не удалось скопировать
'
' wbFromFrom             Книга, компонент из VBA-проекта которой необходимо копировать
'
' wbFromTo               Книга, в VBA-проект которой необходимо копировать компонент
'
' sModuleName            Имя модуля, который необходимо копировать.
'
' bOverwriteExistModule  Если True или 1, то при наличии в конечной книге
'                        компонента с именем sModuleName - он будет удален,
'                        а вместо него импортирован копируемый.
'                        Если False, то при наличии в конечной книге
'                        компонента с именем sModuleName функция вернет False,
'                        а сам компонент не будет скопирован.
'---------------------------------------------------------------------------------------
'
Function CopyVBComponent(sModuleName As String, _
    wbFromFrom As Workbook, wbFromTo As Workbook, _
    bOverwriteExistModule As Boolean) As Boolean
 
    Dim objVBProjFrom As Object, objVBProjTo As Object
    Dim objVBComp As Object, objTmpVBComp As Object
    Dim sTmpFolderPath As String, sVBCompName As String, sModuleCode As String
    Dim lSlashPos As Long, lExtPos As Long
 
    'Проверяем корректность указанных параметров
    On Error Resume Next
    Set objVBProjFrom = wbFromFrom.VBProject
    Set objVBProjTo = wbFromTo.VBProject
 
    If objVBProjFrom Is Nothing Then
        CopyVBComponent = False: Exit Function
    End If
    If objVBProjTo Is Nothing Then
        CopyVBComponent = False: Exit Function
    End If
 
    If Trim(sModuleName) = "" Then
        CopyVBComponent = False: Exit Function
    End If
 
    If objVBProjFrom.Protection = 1 Then
        CopyVBComponent = False: Exit Function
    End If
 
    If objVBProjTo.Protection = 1 Then
        CopyVBComponent = False: Exit Function
    End If
 
    Set objVBComp = objVBProjFrom.VBComponents(sModuleName)
    If objVBComp Is Nothing Then
        CopyVBComponent = False: Exit Function
    End If
 
    '====================================================
    'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение
    sTmpFolderPath = Environ("Temp") & "\" & sModuleName & ".bas" '"
    If bOverwriteExistModule = True Then
        ' Если bOverwriteExistModule = True
        ' удаляем из временной папки и из конечного проекта
        ' модуль с указанным именем
        If Dir(sTmpFolderPath, 6) <> "" Then
            Err.Clear
            Kill sTmpFolderPath
            If Err.Number <> 0 Then
                CopyVBComponent = False: Exit Function
            End If
        End If
        With objVBProjTo.VBComponents
            .Remove .Item(sModuleName)
        End With
    Else
        Err.Clear
        Set objVBComp = objVBProjTo.VBComponents(sModuleName)
        If Err.Number <> 0 Then
            'Err.Number 9 - отсутствие указанного компонента, что нам не мешает.
            'Если ошибка другая - выход из функции
            If Err.Number <> 9 Then
                CopyVBComponent = False: Exit Function
            End If
        End If
    End If
 
    '====================================================
    'Экспорт/Импорт компонента во временную директорию
    objVBProjFrom.VBComponents(sModuleName).Export sTmpFolderPath
    'Получаем имя компонента из экспортированного файла
    lSlashPos = InStrRev(sTmpFolderPath, "\")
    lExtPos = InStrRev(sTmpFolderPath, ".")
    sVBCompName = Mid(sTmpFolderPath, lSlashPos + 1, lExtPos - lSlashPos - 1)
 
    '====================================================
    'копируем
    Set objVBComp = Nothing
    Set objVBComp = objVBProjTo.VBComponents(sVBCompName)
    If objVBComp Is Nothing Then
        objVBProjTo.VBComponents.Import sTmpFolderPath
    Else
        'Если компонент - модуль листа или книги -
        'его нельзя удалить. Поэтому удаляем из него весь код
        'и добавляем код из копируемого компонента
        If objVBComp.Type = 100 Then
            'создаем временный компонент
            Set objTmpVBComp = objVBProjTo.VBComponents.Import(sTmpFolderPath)
            'копируем из него код
            With objVBComp.CodeModule
                .DeleteLines 1, .CountOfLines
                sModuleCode = objTmpVBComp.CodeModule.Lines(1, objTmpVBComp.CodeModule.CountOfLines)
                .InsertLines 1, sModuleCode
            End With
            On Error GoTo 0
            'удаляем временный компонент
            objVBProjTo.VBComponents.Remove objTmpVBComp
        End If
    End If
    'удаляем временный файл компонента
    Kill sTmpFolderPath
    CopyVBComponent = True
End Function

Пример вызова функции CopyVBComponent:

Sub CopyComponent()
    Workbooks.Add
    If CopyVBComponent("ЭтаКнига", ThisWorkbook, ActiveWorkbook, True) Then
        MsgBox "Указанный компонент успешно скопирован в новую книгу", vbInformation
    Else
        MsgBox "Компонент не был скопирован", vbInformation
    End If
End Sub

Думаю теперь у вас не должно возникнуть трудностей с переносом кодов из одной книги в другую.

Также см.:
Как удалить макросы в книге?
Как программно снять пароль с VBA проекта?
Копирование модулей и форм из одной книги в другую


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Outlook Power Query и Power BI VBA работа в редакторе VBA управление кодами Бесплатные надстройки Дата и время Диаграммы и графики Записки Защита данных Интернет Картинки и объекты Листы и книги Макросы и VBA Надстройки Настройка Печать Поиск данных Политика Конфиденциальности Почта Программы Работа с приложениями Работа с файлами Разработка приложений Сводные таблицы Списки Тренинги и вебинары Финансовые Форматирование Формулы и функции Функции Excel Функции VBA Ячейки и диапазоны акции MulTEx анализ данных баги и глюки в Excel ссылки
Обсуждение: 7 комментариев
  1. ioulka:

    прекрасная прога! спасибо большое! но! у меня возникла небольшая проблема пишет
    objVBProjFrom=nothing и выкидывает меня из процедуры (согласно вообщем то логике процедуры). не могу понять почему у меня objVBProjFrom=nothing равно как и objVBProjTo=nothing. Все вроде делаю как надо- задают workbook to & from... почему это может быть не подскажете?

  2. В самом начале статьи есть примечание со ссылкой на статью: Что необходимо для внесения изменений в проект VBA(макросы) программно

  3. ioulka:

    Спасибо огромное!!!! Все получилось! супер сайт и проги!

  4. СергейКр:

    Спасибо, Дмитрий
    Вопрос: при запуске макроса для "создания новых модулей и процедур" с загруженной UserForm (но, не уверен, что в этом причина) весь процесс "создания" появляется на экране (т.е. открывается VBA и визуально видно как все эти новые модули, формы, процедуры создаются). Как визуально скрыть процесс?
    Application.DisplayAlerts = False или Application.ScreenUpdating = False не помогает.

  5. MAGRAW:

    Добрый день.
    Пытаюсь пользовать ваш функционал. Столкнулся с проблемой.
    Что делаю:
    1) Копирую типовые листы из другой книги в рабочую. Никакого дополнительного кода импортируемые листы не содержат на момент копирования.
    2) Добавляю 2 события для импортированного листа

    Private Sub Worksheet_Activate()
    If VE.LoadData True Then Activate_CubeSheet ActiveSheet

    End Sub

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If VE.LoadData True Then
    Set VE.iBook = ActiveWorkbook
    Set VE.iSheet = VE.iBook.ActiveSheet
    Set VE.iRange = Selection 'VE.iSheet.Selection

    VE.firstRange = GetStartLocationAddressRange(Selection)
    VE.endRange = GetEndLocationAddressRange(Selection)
    VE.shzoom = ActiveWindow.Zoom
    VE.SC = ActiveWindow.ScrollColumn
    VE.SR = ActiveWindow.ScrollRow

    VE.iBook.Worksheets("StdGiDNames").Range("H1") = VE.firstRange
    VE.iBook.Worksheets("StdGiDNames").Range("I1") = VE.endRange
    VE.iBook.Worksheets("StdGiDNames").Range("J1") = VE.shzoom
    VE.iBook.Worksheets("StdGiDNames").Range("K1") = VE.SC
    VE.iBook.Worksheets("StdGiDNames").Range("L1") = VE.SR
    End If

    End Sub

    Получаю ошибку "can't enter break mode at this time"
    Далее неприятно уже работать. Точки останова не работают.
    Application.DisplayAlerts = False - не помогает, как и прочие
    Application.Wait time:=Now + 1 / 10 ^ 9
    DoEvents

    Был бы признателен если бы вы подсказали как исключить этот конфликт.

    • Не вижу кода, который хоть как-то согласуется со статьей. Нет ни одного намека, что какой-то из приведенных кодов добавляется программно.

  6. Paxani4:

    Очень полезная статься. У меня только вот такой нюансик. Я вставляю в лист событийную процедуру
    Call CreateEventProcedure_WorkSheetChange(SmetWb.Worksheets("Бухгалтерия"))

    'процедура добавления событийной процедуры на лист
    Sub CreateEventProcedure_WorkSheetChange(Sh As Worksheet)
    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
    Dim lLineNum As Long
    Number = Sh.CodeName

    'получаем ссылку на проект и модуль листа
    Set objVBProj = ActiveWorkbook.VBProject
    Set objVBComp = objVBProj.VBComponents(Sh.CodeName)
    Set objCodeMod = objVBComp.CodeModule
    'вставляем код
    With objCodeMod
    Line = .CountOfLines
    If Line <= 1 Then ' если нет строк, то добавим процедуру
    lLineNum = .CreateEventProc("Change", "Worksheet")
    lLineNum = lLineNum + 1
    .InsertLines lLineNum, " Call Gotovo_Change(Target)"
    End If
    End With
    End Sub

    и у меня после выполнения макроса открывается редактор VBA на модуле листа куда я добавил обработчик события. Как сделать чтобы редактор не открывался или может закрыть его программно?

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти
Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2018 Excel для всех   Войти