Found some code in a previous posting. Almost works. How can I use
the ThisWorkbook.Name property and exclude the .xls extension until the
end?

Thanks!

Dave

Sub BtnSaveAs()
Dim Suggest, res, Fname, Hdr, Fs
Application.DisplayAlerts = False
Suggest = RTrim(ThisWorkbook.Name, 4) & "-" &
Sheets("data").Range("A31").Value & "-" &
Sheets("data").Range("A30").Value
Hdr = "Please choose a Destination for the Copy, give it a name then
click save"
GetFname: Fname = Application.GetSaveAsFilename(Suggest,
fileFilter:="Excel File(*.xls), *.xls)", Title:=Hdr)
If Not Fname = False Then
Set Fs = CreateObject("Scripting.FileSystemObject")
If Fs.FileExists(Fname) Or Fs.FileExists(Fname & ".xls") Then
res = MsgBox(Fname & " already exists." _
& " Do you want to replace it?", vbYesNo, "Duplicate")
If res = vbNo Then GoTo GetFname:
End If
ThisWorkbook.SaveAs Fname
End If
Xit:
Application.DisplayAlerts = True
End Sub