Здравствуйте, прошу Вашей помощи в решении такой проблемы:
Как можно скопировать С Модуля1 макрос и вставить в модуль листа, сделав это макросом ).
Немного лирики. Часто просят сделать, что б при изменение фильтра одной сводной, менялись все сводные на листе.
Так как я лентяй, хочу попробовать сделать Надстройку, клацаешь на кнопку и макрос вставляет процедуру в модуль листа текущей книги активного листа ).
| Код |
|---|
ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(1,60) |
Так планирую собрать весь макрос, а как его теперь впихнуть в модуль ?
Кто что может подсказать навести на путь праведный.
П.С. в макросах не ахти
Файл не загружается вот сам макрос который хочу переместить с модуля в модуль листа:
Скрытый текст |
|---|
| Код |
|---|
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
' При изменении поля находящегося в фильтре рецепиентной сводной, меняется во всех сводных на листе
Dim Piv(1) As Object
Dim i, j As Long
Dim PVErr, PFErr As String
Application.ScreenUpdating = False
Application.EnableEvents = False 'Отключить соббытие, что б не было зацикливания
On Error Resume Next
Set Piv(1) = Target
For i = 1 To PivotTables.Count
If PivotTables(i) <> Piv(1) Then
For j = 1 To Piv(1).PivotFields.Count
If Piv(1).PivotFields(j).Orientation = xlPageField Then
If IsError(PivotTables(i).PivotFields(j).CurrentPage) = True Then
If Trim(PFErr) <> vbNewLine & """" & Piv(1).PivotFields(j).Name & """" Then
PFErr = PFErr & vbNewLine & """" & Piv(1).PivotFields(j).Name & """"
End If
If Trim(PVErr) <> vbNewLine & """" & PivotTables(i).Name & """" Then
PVErr = PVErr & vbNewLine & """" & PivotTables(i).Name & """"
End If
End If
PivotTables(i).PivotFields(j).CurrentPage = _
Piv(1).PivotFields(j).CurrentPage.Name
End If
Next j
End If
'Контроль ошибок-------------------------------------------------------------------------------------
If Err.Description = "Нельзя установить свойство CurrentPage класса PivotField" Then
If i = PivotTables.Count Then
MsgBox "В сводной таблице:" & PVErr & Chr(10) & _
"Отсутствует фильтр по:" & PFErr, vbCritical
Application.ScreenUpdating = True
Application.EnableEvents = True
End
End If
Else
If Err.Description <> "" Then
MsgBox "Не предвиденная ошибка!", vbCritical
Application.ScreenUpdating = True
Application.EnableEvents = True
End
Else
Application.ScreenUpdating = False
Application.EnableEvents = False
End If
End If
'----------------------------------------------------------------------------------------------------
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub |
|
