Save Current Workbook With Extended Filename

[Nate]

Hello,

I'm trying to write a macro to save (save as) the active workbook:

a. in the same directory
b. with a new filename (extension of the original)

Lets say the name of the original file is "test.xls". I would like to
Save As this file as "test_import.xls" in the same directory resulting
in the original file plus a copy with the extended name.

The following is a hard-coded approach which does what I need, but I
need to dynamically determine the file path and edit the name. The
extension to the name will always be "_import."


ChDir "C:\Temp"
ActiveWorkbook.SaveAs Filename:= _
"C:\Temp\test_import.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Any help would be appreciated.

Thanks

 

[Tyla]

See if the following code is useful:

Sub saveMe

Dim sCurrentName as string

' Parse out the name of the current workbook without the path or the
".xls" extension
sCurrentName = Mid(ActiveWorkbook.Name, 1, Len(ActiveWorkbook.Name) -
4)

' Add whatever extension you want
sNewName = sCurrentName & "_import"

' Do a minimal save
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & sNewName

End sub

HTH
/ Tyla /

 

[Mike]

Private Sub SaveWorkbookToFolder()
Dim userInput As String
Dim anyFilename As String
Dim SaveToPath As String

anyFilename = ActiveSheet.Name & ".xls"
SaveToPath ="C:\Temp\test_import.xls"

anyFilename = ActiveSheet.Name & ".xls"
If Dir(SaveToPath & anyFilename) = "" Then

ActiveWorkbook.SaveAs Filename:=SaveToPath & anyFilename
Else

Select Case MsgBox("A file named: '" & ActiveSheet.Name & " already
exists in " & SaveToPath _
& vbCrLf & "What would you like to do?" & vbCrLf _
& "Overwrite the existing file? [Yes]" & vbCrLf _
& "Save file with a different name? [No]" & vbCrLf _
& "Cancel - do not save this file at this time. [Cancel]", _
vbYesNoCancel + vbExclamation + vbDefaultButton2, "Commission
Manager")

Case Is = vbYes

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=SaveToPath & ActiveSheet.Name
Application.DisplayAlerts = True

Case Is = vbNo


userInput = "dummy entry to make it work"

GetFileNameFromUser:
Do While userInput <> ""
anyFilename = InputBox$("Enter a new filename to use:", _
"Commission Manager", ActiveSheet.Name)
If Right(UCase(Trim(anyFilename)), 4) <> ".XLS" Then
anyFilename = anyFilename & ".xls"
End If
If ValidateFilename(anyFilename) <> "" Then

MsgBox "The filename you have entered is not a valid
filename." _
& vbCrLf & "Filenames may not have any of these
characters in them:" _
& vbCrLf & " \ / : * ? < > | " & Chr$(34) & vbCrLf _
& "Please provide a valid filename.", vbOKOnly,
"Invalid Filename"
GoTo GetFileNameFromUser
End If
If Trim(UCase(anyFilename)) = ".XLS" Then

If MsgBox("You have chosen to Cancel the file save." & _
"Did you really intend to Cancel this operation?", _
vbYesNo + vbInformation, "Confirm Cancel") <> vbYes Then
GoTo GetFileNameFromUser
Else

anyFilename = ":* QUIT *:"
userInput = ""
End If
End If
If userInput <> "" Then

userInput = Dir(SaveToPath & anyFilename)
End If
Loop


If anyFilename <> ":* QUIT *:" Then

ActiveWorkbook.SaveAs Filename:=SaveToPath & anyFilename
End If

Case Else


Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True

End Select
End If


End Sub