Всех приветствую! Информации на эту тему порядочно. Читал здесь и здесь, но у меня не получается это реализовать
Есть макрос копирования двух листов в новую книгу
Скрытый текст
Код
Sub CopyLists()
Dim wsSh As Worksheet, NewWb As Workbook, asArr(), li As Long, DateString As String
Dim MyPassword As String, iPath As String
DateString = Format(Sheets("Лист3").Range("A1").Value, "yy_mm_dd")
Application.ScreenUpdating = False
For Each wsSh In Worksheets
If wsSh.Visible <> -1 Then ReDim Preserve asArr(li): asArr(li) = wsSh.Name: li = li + 1: wsSh.Visible = xlSheetVisible
Next wsSh
Sheets(Array("Лист1", "Лист2")).Copy
Set NewWb = ActiveWorkbook
For Each wsSh In NewWb.Worksheets
With wsSh
.Visible = True
.UsedRange.Value = .UsedRange.Value
.Cells.Locked = True
.Cells.FormulaHidden = True
.EnableSelection = xlNoSelection
End With
Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Путь сохранения"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
iPath = .SelectedItems(1) & Application.PathSeparator
End With
NewWb.SaveAs Filename:=iPath & "Копия_" & DateString & ".xls"
NewWb.Close
Application.ScreenUpdating = True
'ThisWorkbook.Close SaveChanges:=False
MsgBox "Копия_" & DateString & " сохранена в папку: " & iPath, vbInformation, "Завершено"
End Sub
В модулях обоих листов на событие Worksheet_Activate повешены макросы. Разумеется они копируются вместе с листами. Код из указанных выше ссылок для удаления макросов в скопированных листах не срабатывает в моем исполнении, когда я его интегрирую в макрос копирования листов. Интегрирую - громко сказано Как варианты, запихивал код после Set NewWb = ActiveWorkbook, пробовал перед вызовом диалога выбора пути для сохранения, и по всякому крутил - тщетно. Метод тыка не сработал, прошу помощи.
Приложу файл примера, может с ним будет удобнее. Там макрос запускается с третьего листа, копирует 1 и 2 листы, создаёт новый файл, но макросы из модулей созданных копированием листов не удаляет... на этом и застревает с ошибкой. Код удаления макросов сам по себе рабочий, я его отдельно проверил. Наверняка я его неверно помещаю в общий макрос. На всякий случай код из файла примера под спойлером.
Скрытый текст
Код
Sub CopyLists()
Dim wsSh As Worksheet, NewWb As Workbook, asArr(), li As Long, DateString As String
Dim iPath As String, iVBComponent As Object ', MyPassword As String
Application.ScreenUpdating = False
DateString = Format(Sheets("Лист3").Range("A1").Value, "yy_mm_dd")
Set NewWb = ActiveWorkbook
Set iVBComponents = NewWb.VBProject.VBComponents
For Each wsSh In Worksheets
If wsSh.Visible <> -1 Then ReDim Preserve asArr(li): asArr(li) = wsSh.Name: li = li + 1: wsSh.Visible = xlSheetVisible
Next wsSh
Sheets(Array("Лист1", "Лист2")).Copy
'Удаление макросов из созданной книги
For Each iVBComponent In iVBComponents
Select Case iVBComponent.Type
Case 1 To 3: iVBComponents.Remove iVBComponent
Case 100
With iVBComponent.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
Set iVBComponents = Nothing
'MyPassword = "******" 'Пароль для защиты листа
For Each wsSh In NewWb.Worksheets
With wsSh
.Visible = True
.UsedRange.Value = .UsedRange.Value
.Cells.Locked = True
.Cells.FormulaHidden = True
'.Protect Password:=MyPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True
.EnableSelection = xlNoSelection
End With
Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Путь сохранения"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
iPath = .SelectedItems(1) & Application.PathSeparator
End With
NewWb.SaveAs Filename:=iPath & "Копия_" & DateString, FileFormat:=xlOpenXMLWorkbook
NewWb.Close
Application.ScreenUpdating = True
'ThisWorkbook.Close SaveChanges:=False
MsgBox "Копия_" & DateString & " сохранена в папку: " & iPath, vbInformation, "Завершено"
End Sub
дело как раз в этом. xlsx формат не подразумевает сохранения макросов, и никакого кода по удалению городить не надо. единственное, что в вашем случае надо будет добавить
Dima S написал: xlsx формат не подразумевает сохранения макросов
Тут не поспоришь. Но таким вариантом эксель ругается, что я пытаюсь сохранить файл с макросами в файл с типом их не поддерживающим. Спасибо за подсказку про отключение сообщений о событиях, сам недотрямкал, но с ними начинается чертовщина. Делаю так:
В итоге новый файл сохраняется, MsgBox не выводится, исходный файл закрывается, новый файл остаётся открытым и еще и спрашивает подтверждение на сохранение изменений при закрытии. Жить, в принципе, можно... но задумка была другая и хочется реализовать именно её.
Sub CopyLists()
Dim wsSh As Worksheet, NewWb As Workbook, DateString As String
Dim iPath As String ', MyPassword As String
Application.ScreenUpdating = False
DateString = Format(Sheets("Лист3").Range("A1").Value, "yy_mm_dd")
For Each wsSh In ThisWorkbook.Worksheets
If wsSh.Visible <> -1 Then wsSh.Visible = xlSheetVisible
Next wsSh
With Application
.EnableEvents = False
.DisplayAlerts = False
ThisWorkbook.Sheets(Array("Лист1", "Лист2")).Copy
.EnableEvents = True
End With
Set NewWb = ActiveWorkbook
'MyPassword = "******" 'Пароль для защиты листа
For Each wsSh In NewWb.Worksheets
With wsSh
.Visible = True 'зачем? они и так видимые
.UsedRange.Value = .UsedRange.Value 'зачем?
.Cells.Locked = True
.Cells.FormulaHidden = True
'.Protect Password:=MyPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True
.EnableSelection = xlNoSelection
End With
Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Путь сохранения"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
iPath = .SelectedItems(1) & Application.PathSeparator
End With
NewWb.SaveAs Filename:=iPath & "Копия_" & DateString & ".xlsx"
NewWb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'ThisWorkbook.Close SaveChanges:=False
MsgBox "Копия_" & DateString & " сохранена в папку: " & iPath, vbInformation, "Завершено"
End Sub
Коллеги, прошу посодействовать в корректировке кода. Задача - сохранить копию активного листа в новую книгу, при этом без макросов, которые ест в исходной книге (и желательно без элементов управления, которые ест на активном лисе (CommandButton1)) Мой код вот такой:
написал: Как сохранить активный лист без макросов в исходном листе?
прочесть тему внимательнее и при сохранении задать нужное расширение и тип файла. А сейчас выглядит так, будто Вы не читая тему совершенно просто задали вопрос, не пытаясь что-то сделать самостоятельно. xls не тоже самое, что xlsx.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
First, you need to set an reference to the VBA Extensibility library. The library contains the definitions of the objects that make up the VBProject. In the VBA editor, go the the Tools menu and choose References. In that dialog, scroll down to and check the entry for Microsoft Visual Basic For Applications Extensibility 5.3. If you do not set this reference, you will receive a User-defined type not defined compiler error.
Код
Sub DeleteAllVBACode()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Sub
в первом сообщении две ссылки - одна из них ведет на мою статью, где такой вариант так же рассматривается, плюс там есть отсылка на подробный разбор того, что еще потребуется для того, чтобы макросы по изменению проекта VBA заработали(например, галка в настройках). Поэтому сохранение в xlsx более универсально.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...