Hello
With a macro I need to close my file and save the file as the sheet
name in the current directory. I can accomplish this with the code
below, but if the file exists and the user selects no to the replace
existing file prompt then, I need to prompt the user to enter a new
name to save the file as under the same directory. Once the new name is
entered I need the macro to continue.

Any help is greatly appreciated.

Dim sPath As String
Dim sh As Worksheet
sPath = ActiveWorkbook.Path
For Each sh In ActiveWorkbook.Worksheets
sh.Copy
ActiveWorkbook.SaveAs sPath & "\" & "Master " & sh.Name & _
".xls", xlNormal
Next


--
nuver
------------------------------------------------------------------------
nuver's Profile: http://www.excelforum.com/member.php...o&userid=10036
View this thread: http://www.excelforum.com/showthread...hreadid=482918

nuver,
One way...
'-------------
Function IsItSafe()
'Jim Cone - San Francisco, USA - Nov 07, 2005
'Requires a project reference to "Microsoft Scripting Runtime" library

Dim objFSO As Scripting.FileSystemObject
Dim sName As String
Dim strPath As String
Dim sPath As String
Dim sh As Excel.Worksheet
sPath = ActiveWorkbook.Path
Set objFSO = New Scripting.FileSystemObject
For Each sh In ActiveWorkbook.Worksheets
strPath = sPath & "\" & "Master " & sh.Name & ".xls"
If Not objFSO.FileExists(strPath) Then
sh.Copy
ActiveWorkbook.SaveAs sPath & "\" & "Master " & sh.Name & ".xls", xlNormal
Else
sName = InputBox(sh.Name & " already exists. " & vbCr & _
"Enter the new file name", "Sheet Save")
sh.Copy
ActiveWorkbook.SaveAs sPath & "\" & sName & ".xls", xlNormal
End If
Next
Set objFSO = Nothing
Set sh = Nothing
End Function
'----------------------


"nuver" wrote in message...
Hello
With a macro I need to close my file and save the file as the sheet
name in the current directory. I can accomplish this with the code
below, but if the file exists and the user selects no to the replace
existing file prompt then, I need to prompt the user to enter a new
name to save the file as under the same directory. Once the new name is
entered I need the macro to continue.

Any help is greatly appreciated.

Dim sPath As String
Dim sh As Worksheet
sPath = ActiveWorkbook.Path
For Each sh In ActiveWorkbook.Worksheets
sh.Copy
ActiveWorkbook.SaveAs sPath & "\" & "Master " & sh.Name & _
".xls", xlNormal
Next
nuver

The following code shows one alternative for completing this type of
operation. The code makes use of the Dir VBA function to check for the
existence of the file, and the FileDialog class to give the user a way to
alternatively save to a different file name. I don't have enough
information to know when you want to close the file (or files), so you will
have to adjust this to your own needs.

Function SaveWorksheets()
Dim sPath As String
Dim sFileName As String
Dim sh As Worksheet
Dim iResult As VbMsgBoxResult
Dim fd As FileDialog

sPath = ActiveWorkbook.Path

For Each sh In ActiveWorkbook.Worksheets
sFileName = sPath & "\" & "Master " & sh.Name & ".xls"
sh.Copy
If Dir(sFileName) < "" Then
iResult = MsgBox("The default file " & sFileName & " already
exists in " & _
"directory " & sPath & ". Do you want to replace
it?", vbQuestion + vbYesNoCancel, "Save File")
If iResult = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sFileName, xlNormal
Application.DisplayAlerts = True
ElseIf iResult = vbNo Then
Set fd = Application.FileDialog(msoFileDialogSaveAs)
fd.InitialFileName = sPath
If fd.Show = -1 Then fd.Execute
End If
Else
ActiveWorkbook.SaveAs sFileName, xlNormal
End If
Next

Set fd = Nothing

End Function


--
David Lloyd
MCSD .NET
http://LemingtonConsulting.com

This response is supplied "as is" without any representations or warranties.


"nuver" wrote in
message ...

Hello
With a macro I need to close my file and save the file as the sheet
name in the current directory. I can accomplish this with the code
below, but if the file exists and the user selects no to the replace
existing file prompt then, I need to prompt the user to enter a new
name to save the file as under the same directory. Once the new name is
entered I need the macro to continue.

Any help is greatly appreciated.

Dim sPath As String
Dim sh As Worksheet
sPath = ActiveWorkbook.Path
For Each sh In ActiveWorkbook.Worksheets
sh.Copy
ActiveWorkbook.SaveAs sPath & "\" & "Master " & sh.Name & _
".xls", xlNormal
Next


--
nuver
------------------------------------------------------------------------
nuver's Profile:
http://www.excelforum.com/member.php...o&userid=10036
View this thread: http://www.excelforum.com/showthread...hreadid=482918

Hello Nuver,

Here is version that will loop until the user inputs a new file name.
If a file is open and you attempt to rename it, the program will catch
the error. The macro will then tell you what it is and then stop. The
comments make the code easy to follow and understand. You can copy this
code and paste it into your project as is. There are no additional
references that you need to add. If you have questions about it,
please ask.

Code:
--------------------
Sub SaveWorkbooks()

Dim Answer
Dim Msg As String
Dim sPath As String
Dim sh As Worksheet
Dim WkbName As String


sPath = ActiveWorkbook.Path & "\"
ChDir (sPath)

Msg = "You must Enter an New File Name," & vbCrLf _
& "before the program can continue."

For Each sh In ActiveWorkbook.Worksheets
WkbName = "Master " & sh.Name & ".xls"
'Check if the Workbook exists
If Dir(WkbName) < "" Then GoSub EnterNewFileName
sh.Copy
ActiveWorkbook.SaveAs WkbName, xlNormal
Next sh

Exit Sub


EnterNewFileName:
'Ask for New File Name - Loop until User Enters a New Name
Answer = InputBox("Please Enter a New File Name in the Box Below.")
'Did User Enter a Name
If Answer = "" Then
'Display Info Message
MsgBox Msg, vbInformation + vbOKOnly
'Display the InputBox again
GoTo EnterNewFileName
End If

'Add ".xls" extention if it is missing
If Right(Answer, 4) < ".xls" Then Answer = Answer & ".xls"
'Create New Workbook Name and Path
Answer = sPath & "Master " & Answer

'Delete the Original Workbook
On Error Resume Next
Kill WbkName

'Trap any Errors that might Occur and Exit
If Err.Number < 0 Then
Msg = "This Routine will Abort." & vbCrLf _
& "Unable to Delete " & WkbName & vbCrLf _
& " Error - " & Err.Number & vbCrLf _
& " " & Err.Description & vbCrLf
MsgBox Msg
Exit Sub
End If

'Assign New Workbook Path, Name and Continue
WkbName = Answer
Return

End Sub

--------------------

Sincerely,
Leith Ross


--
Leith Ross
------------------------------------------------------------------------
Leith Ross's Profile: http://www.excelforum.com/member.php...o&userid=18465
View this thread: http://www.excelforum.com/showthread...hreadid=482918

Thank you all for your suggestions.

Leith
Your code worked like a charm for my needs. Thank you very much. Once
the file is saved under the new name I would like to close the original
file named Master Template without saving changes. I added the code
below to the end of the code you provided but for some reason the
original file remains open. Any suggestions?

Thanks again
Ed



Return

Windows("Master Template.xls").Activate
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub


--
nuver
------------------------------------------------------------------------
nuver's Profile: http://www.excelforum.com/member.php...o&userid=10036
View this thread: http://www.excelforum.com/showthread...hreadid=482918

Hello Nuver,

Place the closing code immediately after the end of the sheet loop. and
before the Exit Sub statement


Next sh

Windows("Master Template.xls").Activate
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True

Exit Sub

Sincerely,
Leith Ross


--
Leith Ross
------------------------------------------------------------------------
Leith Ross's Profile: http://www.excelforum.com/member.php...o&userid=18465
View this thread: http://www.excelforum.com/showthread...hreadid=482918

I'd like to use this on a macro I am writing. How do I make this work in
Excel 2000?

"David Lloyd" wrote:

The following code shows one alternative for completing this type of
operation. The code makes use of the Dir VBA function to check for the
existence of the file, and the FileDialog class to give the user a way to
alternatively save to a different file name. I don't have enough
information to know when you want to close the file (or files), so you will
have to adjust this to your own needs.

Function SaveWorksheets()
Dim sPath As String
Dim sFileName As String
Dim sh As Worksheet
Dim iResult As VbMsgBoxResult
Dim fd As FileDialog

sPath = ActiveWorkbook.Path

For Each sh In ActiveWorkbook.Worksheets
sFileName = sPath & "\" & "Master " & sh.Name & ".xls"
sh.Copy
If Dir(sFileName) < "" Then
iResult = MsgBox("The default file " & sFileName & " already
exists in " & _
"directory " & sPath & ". Do you want to replace
it?", vbQuestion + vbYesNoCancel, "Save File")
If iResult = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sFileName, xlNormal
Application.DisplayAlerts = True
ElseIf iResult = vbNo Then
Set fd = Application.FileDialog(msoFileDialogSaveAs)
fd.InitialFileName = sPath
If fd.Show = -1 Then fd.Execute
End If
Else
ActiveWorkbook.SaveAs sFileName, xlNormal
End If
Next

Set fd = Nothing

End Function


--
David Lloyd
MCSD .NET
http://LemingtonConsulting.com

This response is supplied "as is" without any representations or warranties.


"nuver" wrote in
message ...

Hello
With a macro I need to close my file and save the file as the sheet
name in the current directory. I can accomplish this with the code
below, but if the file exists and the user selects no to the replace
existing file prompt then, I need to prompt the user to enter a new
name to save the file as under the same directory. Once the new name is
entered I need the macro to continue.

Any help is greatly appreciated.

Dim sPath As String
Dim sh As Worksheet
sPath = ActiveWorkbook.Path
For Each sh In ActiveWorkbook.Worksheets
sh.Copy
ActiveWorkbook.SaveAs sPath & "\" & "Master " & sh.Name & _
".xls", xlNormal
Next


--
nuver
------------------------------------------------------------------------
nuver's Profile:
http://www.excelforum.com/member.php...o&userid=10036
View this thread: http://www.excelforum.com/showthread...hreadid=482918

Hello Byron,

I made the needed changes to David Lloyd's code for you. Here it is for
2000.


Code:
--------------------
Function SaveWorksheets()

Dim sPath As String
Dim sFileName As String
Dim sh As Worksheet
Dim iResult As VbMsgBoxResult
Dim fd

sPath = ActiveWorkbook.Path

For Each sh In ActiveWorkbook.Worksheets
sFileName = sPath & "\" & "Master " & sh.Name & ".xls"
sh.Copy
If Dir(sFileName) < "" Then
iResult = MsgBox("The default file " & sFileName & " already
exists in " & _
"directory " & sPath & ". Do you want to replace
it?", vbQuestion + vbYesNoCancel, "Save File")
If iResult = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sFileName, xlNormal
Application.DisplayAlerts = True
ElseIf iResult = vbNo Then
fd = Application.GetSavesAsDialog InitialFileName:= sPath
If fd < "" Then ActiveWorkbook.SaveAs sFileName, xlNormal
End If
Else
End If
Next

End Function

--------------------

Sincerely,
Leith Ross


--
Leith Ross
------------------------------------------------------------------------
Leith Ross's Profile: http://www.excelforum.com/member.php...o&userid=18465
View this thread: http://www.excelforum.com/showthread...hreadid=482918

Thanks, excellent.

"Leith Ross" wrote:


Hello Byron,

I made the needed changes to David Lloyd's code for you. Here it is for
2000.


Code:
--------------------
Function SaveWorksheets()

Dim sPath As String
Dim sFileName As String
Dim sh As Worksheet
Dim iResult As VbMsgBoxResult
Dim fd

sPath = ActiveWorkbook.Path

For Each sh In ActiveWorkbook.Worksheets
sFileName = sPath & "\" & "Master " & sh.Name & ".xls"
sh.Copy
If Dir(sFileName) < "" Then
iResult = MsgBox("The default file " & sFileName & " already
exists in " & _
"directory " & sPath & ". Do you want to replace
it?", vbQuestion + vbYesNoCancel, "Save File")
If iResult = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sFileName, xlNormal
Application.DisplayAlerts = True
ElseIf iResult = vbNo Then
fd = Application.GetSavesAsDialog InitialFileName:= sPath
If fd < "" Then ActiveWorkbook.SaveAs sFileName, xlNormal
End If
Else
End If
Next

End Function

--------------------

Sincerely,
Leith Ross


--
Leith Ross
------------------------------------------------------------------------
Leith Ross's Profile: http://www.excelforum.com/member.php...o&userid=18465
View this thread: http://www.excelforum.com/showthread...hreadid=482918