Metusion
02-01-2012, 02:34 AM
I have a macro that creates a statistic at the end of the month by sorting out the relevant sheets and putting them into a new workbook. Now when I run this macro it doesn't save a new file and it also deletes all defined names in the workbook. I have no idea why this happens.
I'm using the following code:
Sub CreateStat()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If ThisWorkbook.Worksheets(1).ProtectContents = True Then
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect
Next 'wks
End If
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
For Each wsname In Array("DECKBLATT", "MGB STATS", "HRI STATS", "SRE STATS", "RCO STATS", "JUH AAM STATS", "KST STATS", "DRE STATS", "JCH STATS", "SLO STATS", "MSG STATS", "SVS STATS", "RSB STATS", "USO STATS", "PKR STATS", "SVS STATS", "PBO STATS", "CLG STATS", "ANE STATS", "MAK STATS", "RWA STATS", "YBO STATS", "HPA STATS", "KTZ STATS", "TOTAL")
Worksheets(wsname).Visible = True
Next
Sheets(Array("DECKBLATT", "MGB STATS", "HRI STATS", "SRE STATS", "RCO STATS", "JUH AAM STATS", "KST STATS", "DRE STATS", "JCH STATS", "SLO STATS", "MSG STATS", "SVS STATS", "RSB STATS", "USO STATS", "PKR STATS", "SVS STATS", "PBO STATS", "CLG STATS", "ANE STATS", "MAK STATS", "RWA STATS", "YBO STATS", "HPA STATS", "KTZ STATS", "TOTAL")).Copy
Sheets(Array("DECKBLATT", "MGB STATS", "HRI STATS", "SRE STATS", "RCO STATS", "JUH AAM STATS", "KST STATS", "DRE STATS", "JCH STATS", "SLO STATS", "MSG STATS", "SVS STATS", "RSB STATS", "USO STATS", "PKR STATS", "SVS STATS", "PBO STATS", "CLG STATS", "ANE STATS", "MAK STATS", "RWA STATS", "YBO STATS", "HPA STATS", "KTZ STATS", "TOTAL")).Visible = False
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
'Prompt for SaveAs name
If ThisWorkbook.Worksheets(1).ProtectContents = False Then
For Each ws In ThisWorkbook.Worksheets
ws.Protect
Next 'wks
End If
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
I'm using the following code:
Sub CreateStat()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If ThisWorkbook.Worksheets(1).ProtectContents = True Then
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect
Next 'wks
End If
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
For Each wsname In Array("DECKBLATT", "MGB STATS", "HRI STATS", "SRE STATS", "RCO STATS", "JUH AAM STATS", "KST STATS", "DRE STATS", "JCH STATS", "SLO STATS", "MSG STATS", "SVS STATS", "RSB STATS", "USO STATS", "PKR STATS", "SVS STATS", "PBO STATS", "CLG STATS", "ANE STATS", "MAK STATS", "RWA STATS", "YBO STATS", "HPA STATS", "KTZ STATS", "TOTAL")
Worksheets(wsname).Visible = True
Next
Sheets(Array("DECKBLATT", "MGB STATS", "HRI STATS", "SRE STATS", "RCO STATS", "JUH AAM STATS", "KST STATS", "DRE STATS", "JCH STATS", "SLO STATS", "MSG STATS", "SVS STATS", "RSB STATS", "USO STATS", "PKR STATS", "SVS STATS", "PBO STATS", "CLG STATS", "ANE STATS", "MAK STATS", "RWA STATS", "YBO STATS", "HPA STATS", "KTZ STATS", "TOTAL")).Copy
Sheets(Array("DECKBLATT", "MGB STATS", "HRI STATS", "SRE STATS", "RCO STATS", "JUH AAM STATS", "KST STATS", "DRE STATS", "JCH STATS", "SLO STATS", "MSG STATS", "SVS STATS", "RSB STATS", "USO STATS", "PKR STATS", "SVS STATS", "PBO STATS", "CLG STATS", "ANE STATS", "MAK STATS", "RWA STATS", "YBO STATS", "HPA STATS", "KTZ STATS", "TOTAL")).Visible = False
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
'Prompt for SaveAs name
If ThisWorkbook.Worksheets(1).ProtectContents = False Then
For Each ws In ThisWorkbook.Worksheets
ws.Protect
Next 'wks
End If
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub