Если вам нужно так сделать на каждом листе в новой книге то измените эту часть:  
 
With wsSh  
.Visible = True    
.[A1:Z266].Value = .[A1:Z266].Value
.Cells.Locked = False  
.[A1:Z266].Locked = True
.[A1:Z266].FormulaHidden = True
.Protect Password.....

Если состояние флажков нельзя менять - для чего они тогда вообще? При копировании листа их состояние не меняется.

>>Но на данный момент задача заключается в том, чтобы получить документ, доступный для изменений с тем же успехом, как картинка jpg  
 
установите виртуальный принтер и печатайте в pdf  
doPDF

{quote}{login=Black__Hole}{date=26.09.2011 02:20}{thema=vba: копирование листа в новую книгу}{post}Добрый день!  
Знаю, как скопировать лист в новую книгу с переносом всех значений и защитить ячейки от изменений (спасибо планете!):  
 
   Dim wsSh As Worksheet  
   Dim NewWb As Workbook, asArr(), li As Long  
   DateString = Format(Now, "dd-mm-yy hh-mm-ss")  
   Application.ScreenUpdating = False  
   For Each wsSh In Sheets(Array("Заявление"))  
       If wsSh.Visible <> -1 Then ReDim Preserve asArr(li): asArr(li) = wsSh.Name: li = li + 1: wsSh.Visible = xlSheetVisible  
   Next wsSh  
   Sheets(Array("Заявление")).Copy      
   Set NewWb = ActiveWorkbook  
   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  
   NewWb.SaveAs Filename:=ActiveWorkbook.Path & DateString & "_Заявление.xls"  
   Application.ScreenUpdating = True  
   ThisWorkbook.Close SaveChanges:=False  
 
 
А мне надо, чтобы при копировании листа диапазон [A1:Z266] переносился в виде значений (а не формул) с защитой от изменений, а все остальное, где хоть что-то есть, с сохранением формул и без защиты. Подскажите, пожалуйста, как это сделать?{/post}{/quote}
 
Скажите, пожалуйста, а как сделать так, чтобы копировались два листа на новую книгу? То есть два листа с одной книги (как в примере "Заявление", и ещё допустим второй "Образец") в один новый файл?

Для копирования 2-х листов  
Вместо: Sheets(Array("Заявление")).Copy  
Должно быть: Sheets(Array("Заявление", "Образец")).Copy

Малышка Стьюи, надо перечислить n-ую сумму на следующие реквизиты... ]:->

вот вернется ZVI - он главный знаток и филантроп :)

ууу, злые жители Планеты, всё бы вам на бедных девушках наживаться )))  
я вон с октября сижу без работы и ничего ... ещё не помер с голоду ))    
 
Sub test()  
   Dim wsSh As Worksheet, NewWb As Workbook, asArr(), li As Long, DateString As String  
   Dim MyPassword As String, iPath As String  
 
   DateString = Format(Now, "dd-mm-yy hh-mm-ss")  
   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("Заявление", "Образец")).Copy  
   Set NewWb = ActiveWorkbook  
   MyPassword = "1"    'ПАРОЛЬ ЛИСТА  
   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 & "_Заявление.xls"  
   NewWb.Close  
   Application.ScreenUpdating = True  
   'ThisWorkbook.Close SaveChanges:=False  
   MsgBox "Листы 'Заявление' и 'Образец' сохранены в папку: " & iPath, vbInformation, "Конец"  
End Sub

>я вон с октября сижу без работы и ничего ... ещё не помер с голоду ))    
А семья? Как, нормально себя чувствует?) А если серьезно: слишком много халявы на Планете (мое мнение). Даже для тех, кто не прикладывает никаких усилий для решения задачи (клянчить не в счет).  
 
>а до вечера далеко ещё  
Кому далеко, а кому час-другой)  
 
школьные оценки  
20212

Спасибо. Писать не буду )  
 
P.S. Если хотите отблагодарить, скажите мне просто спасибо (данный код не стоит больше :) ), если хотите что-то спросить по Excel спрашивайте тут, мы поможем )

поэтому я и написал "если хотите что-то спросить по Excel спрашивайте тут, мы поможем )"  
 
Создайте тему с вашим вопросом и файлом-примреом, а мы посмотрим, чем вам можем помочь.  
 
P.S. Я не пишу никому на почту

{quote}{login=Степлер}{date=16.01.2012 06:21}{thema=}{post}поэтому я и написал "если хотите что-то спросить по Excel спрашивайте тут, мы поможем )"  
 
Создайте тему с вашим вопросом и файлом-примреом, а мы посмотрим, чем вам можем помочь.  
 
P.S. Я не пишу никому на почту{/post}{/quote}  
 
Степлер, у меня есть задача, которую нужно сделать. Мне не нужна помощь, мне нужно сделать полностью от и до. Форум мне не подъодит, так как нужно, чтобы кто-то отвечал за результат и сроки. Вам это интересно? По почте вышлю подробное описание.

>данный код не стоит больше  
Степлер, Павел, если не ошибаюсь : ) Не сочтите за труд, сходите по этой (см. ниже) ссылке и прочитайте то, что в блоке с пометкой "цитата".  
<EM>http://forum.htmlbook.ru/index.php?showtopic=31842&view=findpost&p=240273</EM>