Макрос сохраниения листа книги

[staniiislav]

Здравствуйте Уважаемые форумчане!
Посздравляю Вас с наступающими праздниками, желаю счастья, здоровь, долгой и крепкой памяти!
Помогите пожалуйста подправить макрос сохранения активного листа книги и при сохранении чтобы сохранялись (преобразовывались формулы в значения) только значения в сохраняемом листе, а оригенал листа оставался не изменимым. В книге есть несколько листов и на них стоит защита листов, при сохранении нужно чтобы защита листа как в сохраняемом, так и в оригинале книги осталось.
Вот есть макрос, его и нужно подправить:

Sub Save()
Dim WbMain As Workbook
Dim Wb As Workbook
Dim FolderName As String
Dim Date_name As String
Application.EnableEvents = False
Set WbMain = ActiveWorkbook
FolderName = WbMain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
Date_name = CStr(InputBox("Введиту дату для текущего периода (пример: май 2011)! ", "Дата"))
If Date_name <> Empty Then
If ActiveWorkbook.Visible = -1 Then
ActiveWorkbook.Copy я так понимаю нужно подправить что-то в выделения текста красным цветом
Set Wb = ActiveWorkbook
Wb.SaveAs FolderName _
& "\" & "Рапорт " & " " & Date_name & ".xls"
'Wb.Close False
End If
MsgBox "Книга " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName
End If
Application.EnableEvents = True
End Sub


Заранение огромное спасибо!

[staniiislav]

Помогите пожалуста, уже сохранение сделал листа сделал. только ошибку выдает что форматы файлов отличаются, но книга открывается.
как убрать эту ошибку и как сохранять только значения листа?

[nilem]

Сообщение от staniiislav

Заранение огромное спасибо!

Ранить не будем, сразу убьем.
Попробуйте так:

Sub Save()
Dim WbMain As Workbook, Wb As Workbook
Dim FolderName As String, Date_name As String
'Application.EnableEvents = False
Application.ScreenUpdating = False
Set WbMain = ActiveWorkbook
FolderName = WbMain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
Date_name = InputBox("Введиту дату для текущего периода (пример: май 2011)! ", "Дата")
If Date_name <> Empty Then
    If ActiveWorkbook.Visible = -1 Then
        ActiveSheet.Copy
        With ActiveWorkbook
            With .Sheets(1).UsedRange: .Value = .Value: End With
            .SaveAs Filename:=FolderName & "\Рапорт " & Date_name & ".xls", FileFormat:=-4143
            .Close False
        End With
    End If
    MsgBox "Книга " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName
End If
'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

EnableEvents закомментировал - не знаю для чего оно здесь.

[staniiislav]

Сообщение от nilem

Ранить не будем, сразу убьем.
Попробуйте так:

Sub Save()
Dim WbMain As Workbook, Wb As Workbook
Dim FolderName As String, Date_name As String
'Application.EnableEvents = False
Application.ScreenUpdating = False
Set WbMain = ActiveWorkbook
FolderName = WbMain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
Date_name = InputBox("Введиту дату для текущего периода (пример: май 2011)! ", "Дата")
If Date_name <> Empty Then
    If ActiveWorkbook.Visible = -1 Then
        ActiveSheet.Copy
        With ActiveWorkbook
            With .Sheets(1).UsedRange: .Value = .Value: End With
            .SaveAs Filename:=FolderName & "\Рапорт " & Date_name & ".xls", FileFormat:=-4143
            .Close False
        End With
    End If
    MsgBox "Книга " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName
End If
'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

EnableEvents закомментировал - не знаю для чего оно здесь.

))) спасибо огромное ))), я вот методом тыка сделал вот так:

Sub Save()
Dim WbMain As Workbook
Dim Wb As Workbook
Dim FolderName As String
Dim Date_name As String
'Application.EnableEvents = False
Application.ScreenUpdating = False
Set WbMain = ActiveWorkbook
FolderName = WbMain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
Date_name = CStr(InputBox("Введиту дату для текущего периода (пример: май 2011)! ", "Дата"))
If Date_name <> Empty Then
If ActiveWorkbook.Visible = -1 Then
ActiveSheet.Unprotect
ActiveSheet.Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
Set Wb = ActiveWorkbook
Wb.SaveAs FolderName _
& "\" & "Рапорт " & " " & Date_name & ".xls", FileFormat:=-4143
Wb.Close False
End If
End If
MsgBox "Книга " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName

'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

силь тупа я сделал?

[staniiislav]

Сообщение от nilem

Ранить не будем, сразу убьем.
Попробуйте так:

Sub Save()
Dim WbMain As Workbook, Wb As Workbook
Dim FolderName As String, Date_name As String
'Application.EnableEvents = False
Application.ScreenUpdating = False
Set WbMain = ActiveWorkbook
FolderName = WbMain.Path & "\Archive"
On Error Resume Next
MkDir FolderName
Date_name = InputBox("Введиту дату для текущего периода (пример: май 2011)! ", "Дата")
If Date_name <> Empty Then
    If ActiveWorkbook.Visible = -1 Then
        ActiveSheet.Copy
        With ActiveWorkbook
            With .Sheets(1).UsedRange: .Value = .Value: End With
            .SaveAs Filename:=FolderName & "\Рапорт " & Date_name & ".xls", FileFormat:=-4143
            .Close False
        End With
    End If
    MsgBox "Книга " & ActiveSheet.Name & " в виде одного файла сохранен в папку " & FolderName
End If
'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

EnableEvents закомментировал - не знаю для чего оно здесь.

Спасибо большое Вас! Взял за основу Ваш вариант!

[nilem]

Вместо этого:

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

имхо, лучше будет:

With .Sheets(1).UsedRange: .Value = .Value: End With

или, если там защита:

With .Sheets(1)
       .Unprotect
       .UsedRange.Value = .UsedRange.Value
       .Protect
End With

Это в ответ на предпредыдущий пост

[staniiislav]

Сообщение от nilem

Вместо этого:

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

имхо, лучше будет:

With .Sheets(1).UsedRange: .Value = .Value: End With

или, если там защита:

With .Sheets(1)
       .Unprotect
       .UsedRange.Value = .UsedRange.Value
       .Protect
End With

Это в ответ на предпредыдущий пост

Спасибо вам огромное nilem!!! вот какой мой итоговый вариант:

Код:


Sub Save()
If MsgBox("Сохранить рапорт в Архив?", vbYesNo, "Подтверждение") = vbYes Then
Dim iyear As String, idate As Date
Dim Wsh As Worksheet
Dim FolderName As String
Dim fg_ As String, fm_ As String
'Application.EnableEvents = False
Application.ScreenUpdating = False

FolderName = ThisWorkbook.Path & "\Archive"
On Error Resume Next
MkDir FolderName

Set Wsh = ThisWorkbook.ActiveSheet: iyear = CStr(Year([B9])): idate = [B9]
fg_ = Format(idate, "yyyy"): fm_ = Format(idate, "mmmm")
If idate <> Empty Then
If ActiveWorkbook.Visible = -1 Then
ActiveSheet.Unprotect
ActiveSheet.Copy

With ActiveWorkbook
.Sheets(1).Shapes(1).Delete
With ActiveSheet.UsedRange: .Value = .Value: End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
.SaveAs Filename:=FolderName & "\" & fg_ & "\" & fm_ & "\Рапорт " & Wsh.Name & " (" & idate & ").xls", FileFormat:=-4143
.Close False
End With
End If

MsgBox "Лист " & Wsh.Name & " в виде одного файла сохранен в папку " & FolderName & "\" & fg_ & "\" & fm_
End If
End If
'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[nilem]

Переменная iyear не лишняя?
Первую строчку можно так:

If MsgBox("Сохранить рапорт в Архив?", vbYesNo, "Подтверждение") = vbNo Then Exit Sub

и тогда последний End If убираем.

[staniiislav]

Сообщение от nilem

Переменная iyear не лишняя?
Первую строчку можно так:

If MsgBox("Сохранить рапорт в Архив?", vbYesNo, "Подтверждение") = vbNo Then Exit Sub

и тогда последний End If убираем.

Вы абсолютно правы. Убрал ненужную переменную и убрал последний ИФ.
Спасибо ))) я почти счастлив ))))