View Single Post
  #4   Report Post  
Posted to microsoft.public.excel.programming
joel joel is offline
external usenet poster
 
Posts: 9,101
Default Copy Module to new Workbook

Your are making perfect sense. Save the blank worksheet with all the bells
and whistles (modules,buttons, etc ...). This will be a templet. Open this
file in the macro instead of creating a new workbook. Then add all the data
into the templet and save the file using the saveas (as in your code already)
under a different file name. The templet file never gets modified. You can
reuse this templet over and over again.

"Little Penny" wrote:

The original spreadsheet is really a form that other people use to
request information. When the form (originals spreadsheet) which is
password protected and sits on a network drive is filled out it copies
itself to a new workbook save itself with the name the users request
and email itself to me.

There is a macro button on the spreadsheet that once the use fills in
all the information that activates this code.

The way it is now the user just fills in the info and presses a
button.

I'm I making any sense












On Sat, 15 Sep 2007 11:42:01 -0700, Joel
wrote:

Penny: Instead of creating a new workbook, Open up an empty xls file that
contains module 2. Then copy the worksheet into opened file and saveas a new
filename as you have already done in your code.

"Little Penny" wrote:

The code below copies a worksheet into a new book and then emails the
new workbook. When the original worksheet is copied to a new workbook
how can I modify my code to also copy Module5 to the new workbook?

My Code:



Sub MoveData()
On Error GoTo ErrHandler
Dim lastrow As Long, TempFilePath As String, TempFileName As String,
lastemail As Byte
Dim MyRecipients() As Variant, cel As Range, rg As Range, i As Long,
response As Byte
Dim TempCleanName As String, TempDateName As String

response = MsgBox("Are you sure you want to process this
request?", vbQuestion + vbOKCancel, "Confirm request process")

If response = vbCancel Then
End
End If

If Range("B4") = "" Or Range("B5") = "" Or Range("A8") = "" Or
Range("B8") = "" Or Range("C8") = "" Or Range("D8") = "" Or
Range("E8") = "" Or Range("A20") = "" Or Range("B22") = "" Then
MsgBox "Form was not properly filled out, please check the
values and try again.", vbInformation, "Missing Data"
End
End If

Sheets("EMAIL LIST").Select
Cells.Select
ActiveSheet.Unprotect Password:="sj23"
Range("A1").Select
'removes hyperlinks
lastemail = Range("A65536").End(xlUp).Row

Columns("A:A").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A1").Select

Range("A2", "A" & lastemail).Select
Selection.Hyperlinks.Delete

Range("A1").Select

'creates array of email addy's for use with sendmail
Set rg = Sheets("EMAIL LIST").Range([A2], [A65536].End(xlUp))
ReDim MyRecipients(Application.CountA(rg))
For Each cel In rg
If cel < "" Then
MyRecipients(i) = cel
i = i + 1
End If
Next

'copy worksheet to new workbook
ThisWorkbook.Sheets("Move Request").Copy
ActiveSheet.Unprotect Password:="2j23"
'get path for temp directory
Range("H6").Select
Selection.ClearContents
Range("A1:G22").Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$G$23"
Range("A5").Select
Range("A1").Select
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.Zoom = 100
Cells.Select
Selection.Locked = True
Selection.FormulaHidden = False

TempFilePath = Environ$("temp") & "\"
'generate filename
'calls function to parse out invalid name characters
TempCleanName = CleanData(ActiveWorkbook.Sheets("Move
Request").Range("B4").Value)
TempDateName = ActiveWorkbook.Sheets("Move
Request").Range("F4").Value
TempFileName = TempCleanName & " " & Format(TempDateName,
"dd-mmm-yy") & ".xls"
Range("A4").Select
'save workbook with temp name to temp path
ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName
ActiveWorkbook.Sheets("Move Request").Select

'format worksheet to send as attachment
ActiveSheet.Unprotect
Rows("41:43").Delete
ActiveSheet.Shapes("Rectangle 3").Delete
ActiveSheet.Shapes("Rectangle 2").Delete
Range("G5").Select
Range("A4").Select
ActiveSheet.Protect Password:="2j23"
'send as attachment
ActiveWorkbook.SendMail Recipients:=MyRecipients, Subject:="MOVE
REQUEST for " & _
Range("B4").Value & " " & Range("F5").Value & " " &
Range("B5").Value & " requested: " &
Format(ActiveWorkbook.Sheets("Move Request").Range("F4").Value,
"mmm/dd/yy")
'close without saving and delete temp file
ActiveWorkbook.Close SaveChanges:=False
Kill TempFilePath & TempFileName

'ThisWorkbook.Sheets("Move Request").Select
'copy the data in the form
'Range("A43:P43").Select
'Selection.Copy

'ThisWorkbook.Sheets("Data Logs").Select
'paste the data from the form into the table
'lastrow = Range("A65536").End(xlUp).Row
'Range("A" & lastrow + 1).Select
'Selection.PasteSpecial Paste:=xlPasteValues
'Range("A" & lastrow + 1).Select

ThisWorkbook.Sheets("Move Request").Select
'clear the data from the form
Call ClearData

Sheets("EMAIL LIST").Select
ActiveSheet.Protect Password:="2j23"

Sheets("Move Request").Select
ActiveSheet.Protect Password:="2j23"
Range("A1").Select

ExitHe
Exit Sub
ErrHandler:
MsgBox "An unexpected error occured, please check the data and try
again" & vbCrLf & _
Error$, vbCritical, "Unexpected Error"
Resume ExitHere
End Sub




Thanks for you help