View Full Version : Solved: Copy a Sheet,delete a range Then save the org Template

01-15-2011, 10:36 AM
Hi All

I have a excel template from which we download info from our DMS system.
I have managed to copy the template from the original and put it in C folder ok.
The next step i wanted to create, was to close the copy sheet, then go back to the original template, delete range A2:P500 save the sheet then quit excel.
Password for the sheet = "AMN"
Have attached a copy with the code if anybody could help with the missing bits.


01-16-2011, 05:04 AM
Here is the code to save opening the file:
'//In the worksheet
Option Explicit
Sub CommandButton1_Click()
Call Module1.CommandButton1_Click

Workbooks.Open Filename:="C:\AMN\Nissan Template.xls"

End Sub

'//In module 1

Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim _
wksCopy As Worksheet, _
wkscmdBttn As OLEObject, _
wbNew As Workbook, _
wksNew As Worksheet, _
strFullName As String, _
MyFilePath As String

Const PWD As String = "AMN"
Application.EnableEvents = False

'// Copy the worksheet to past the last sheet and set a reference to the copy.
With ThisWorkbook
.Worksheets("sheet1").Copy After:=.Worksheets(.Worksheets.Count)
Set wksCopy = .Worksheets(.Worksheets.Count)
End With

With wksCopy
'// Change path to suit...C:\
MyFilePath = "C:\AMN\"
strFullName = "C:\AMN\Nissan Template Data" & " " & Format(Now, "YYYY-MM-DD HH_MM_SS") & ".xls"
'// Unprotect the new copy, kill any commandbuttons and re-protect.
.Unprotect Password:=PWD
For Each wkscmdBttn In .OLEObjects
If TypeName(wkscmdBttn.Object) = "CommandButton" Then
End If
'// Set a reference to a new, one-sheet wb; move the copied sheet to it, kill
'// the blank sheet.
Set wbNew = Workbooks.Add(xlWBATWorksheet)
.Move After:=wbNew.Worksheets(1)
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End With

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

With ActiveWorkbook.Sheets(1).Cells
End With
'// Set a reference to the copied sheet in the new wb, rename the sheet (to rid the
'// " (2)" ), and save the new wb.
With wbNew
Set wksNew = .Worksheets(1)
wksNew.Name = "Nissan Data"
'// Protect the copy sheet & all ranges to stop anybody amending the data

Selection.Locked = True
Selection.FormulaHidden = True
ActiveSheet.Protect Password:=PWD
ActiveWorkbook.Protect Password:=PWD

'// Check if folder exsists if not create one
On Error Resume Next '<< a folder exists resume next line
Application.DisplayAlerts = False
MkDir MyFilePath '<< create a folder
Application.DisplayAlerts = True
.SaveAs Filename:=strFullName
End With
Application.ScreenUpdating = True
ActiveSheet.Close False
ThisWorkbook.Close False
End Sub