Here is a macro that should do what you want ?
Sub SaveAs_Index()
Dim Fname As String
Dim OldName As String
Dim NewName As String
Dim i As Integer
OldName = ActiveWorkbook.FullName
Fname = ActiveWorkbook.Name
If Dir("C:\ExcelFiles\Useful\" & Fname) <> "" Then
'The oldfilename exists here
'So Get Index Number
i = GetIndexnumber(Fname) + 1
Dim pos
pos = InStr(1, Get_FileNameOnly(Fname), i - 1) - 1
If pos = -1 Then
NewName = Get_FileNameOnly(Fname) & i & ".xls"
Else
NewName = Left(Get_FileNameOnly(Fname), pos) & i & ".xls"
End If
ActiveWorkbook.SaveAs Filename:="C:\ExcelFiles\Useful\" & NewName
Else
MsgBox "This workbook doesn't exist@ " & "C:\ExcelFiles\Useful\"
End If
End Sub
Function GetIndexnumber(Filename As String) As Integer
Dim FnameOnly As String, Temp As String
Dim x As Integer, i As String
Dim N As Integer
Dim StgOnly As Boolean
FnameOnly = Get_FileNameOnly(Filename)
x = 0
On Error Resume Next
Do
Temp = Mid(FnameOnly, Len(FnameOnly) - x, 1)
i = Temp & i
x = x + 1
'CInt will generate an error if we get a string
N = CInt(i)
'Check if x > = Strng Only NO numbers
If x > Len(FnameOnly) Then StgOnly = True: Exit Do
Loop Until Err.Number <> 0
On Error GoTo 0
If Not StgOnly Then
'Has an index already so...
GetIndexnumber = N
Else
'Must be a string only
GetIndexnumber = 0
End If
End Function
Function Get_FileNameOnly(FullName As String) As String
'Gets name of workbook NO extensions
'given the ActiveWorkbook.Name
Dim Temp As String
Dim x As Integer
Do Until Temp = "."
Temp = Mid(FullName, Len(FullName) - x, 1)
x = x + 1
Loop
Get_FileNameOnly = Left(FullName, Len(FullName) - x)
End Function
HTH
Ivan
Thanks for the above. This works great for saving consecutively numbered files (file1.xls saves to file2.xls saves to file3.xls, etc.
Is there a way for the code to automatically add 1 to whatever file exists in the directory?
That is, if I have filename.xls open and there already exists filename1.xls and filename2.xls in the designated directory, the macro automatically creates filename3.xls.
Thanks.