Simplify code and/or amending saveas filename

[wwbwb]

Greetings all. The following code works. I'm just wondering if,
1. If it can be simplified,
2. Automatically adjust the amending of the save as filename.

First, the code checks the length of the filename and if too long, will save it with the date (rdate) along with the words Receipt Multiple. If it isn't too long, then the it will save with the date (rdate), "Receipt", and the contents of a cell. It also checks whether or not the file already exists. If it does, it will amend it with a 2. If the 2 exists, then it amends it with a 3. I'm looking for something simpler in case I need to go higher than 3 amends.

If Len(Receiptpath + rdate + " RECEIPT " + itemname + ".xlsm") < 215 Then
 If Dir(Receiptpath + rdate + " RECEIPT " + itemname + ".xlsm") = "" Then
  ActiveWorkbook.SaveAs Filename:=Receiptpath + rdate + " RECEIPT " + itemname + ".xlsm"
  ActiveWorkbook.SaveAs Filename:=Stimmelpath + rdate + " RECEIPT " + itemname + ".xlsm"
  Else
  If Dir(Receiptpath + rdate + " RECEIPT " + itemname + " 2" + ".xlsm") = "" Then
   ActiveWorkbook.SaveAs Filename:=Receiptpath + rdate + " RECEIPT " + itemname + " 2" + ".xlsm"
   ActiveWorkbook.SaveAs Filename:=Stimmelpath + rdate + " RECEIPT " + itemname + " 2" + ".xlsm"
   Else
   ActiveWorkbook.SaveAs Filename:=Receiptpath + rdate + " RECEIPT " + itemname + " 3" + ".xlsm"
   ActiveWorkbook.SaveAs Filename:=Stimmelpath + rdate + " RECEIPT " + itemname + " 3" + ".xlsm"
  End If
 End If
 Else
 If Dir(Receiptpath + rdate + " RECEIPT Multiple.xlsm") = "" Then
  ActiveWorkbook.SaveAs Filename:=Receiptpath + rdate + " RECEIPT Multiple.xlsm"
  ActiveWorkbook.SaveAs Filename:=Stimmelpath + rdate + " RECEIPT Multiple.xlsm"
  Else
  If Dir(Receiptpath + rdate + " RECEIPT Multiple" + " 2" + ".xlsm") = "" Then
   ActiveWorkbook.SaveAs Filename:=Receiptpath + rdate + " RECEIPT Multiple" + " 2" + ".xlsm"
   ActiveWorkbook.SaveAs Filename:=Stimmelpath + rdate + " RECEIPT Multiple" + " 2" + ".xlsm"
   Else
   ActiveWorkbook.SaveAs Filename:=Receiptpath + rdate + " RECEIPT Multiple" + " 3" + ".xlsm"
   ActiveWorkbook.SaveAs Filename:=Stimmelpath + rdate + " RECEIPT Multiple" + " 3" + ".xlsm"
  End If
 End If
End If

 

[DeBeuz]

Hi,

Try something similar to this

    Dim Cnt
    Dim FoundName As String
    Dim Wrk As String
    Dim WorkItemName As String

    WorkItemName = itemname
    If Len(Receiptpath + rdate + " RECEIPT " + WorkItemName + ".xlsm") >= 215 Then _
        WorkItemName = "Multiple"
        
    'Find long or short name; fetch number of files
    FoundName = Dir(Receiptpath + rdate + " RECEIPT " + WorkItemName + ".xlsm")
    Cnt = 0
    While FoundName <> ""
        Cnt = Cnt + 1
        FoundName = Dir()
    Wend
    Wrk = ""
    If Cnt > 0 Then Wrk = " " + (Cnt + 1)
    ActiveWorkbook.SaveAs Receiptpath + rdate + " RECEIPT " + WorkItemName + Wrk + ".xlsm"
    ActiveWorkbook.SaveAs Stimmelpath + rdate + " RECEIPT " + WorkItemName + Wrk + ".xlsm"

 

[wwbwb]

That almost worked. I made a couple changes. It kept overwriting the 2nd copy. Thanks for your help in getting me into the right direction.

    Dim Cnt
    Dim FoundName As String
    Dim Wrk As String
    Dim WorkItemName As String

    WorkItemName = itemname
    If Len(Receiptpath + rdate + " RECEIPT " + WorkItemName + ".xlsm") >= 215 Then _
        WorkItemName = "Multiple"
        
    'Find long or short name; fetch number of files
    FoundName = Dir(Receiptpath + rdate + " RECEIPT " + WorkItemName + [COLOR=#ff0000]"*" +[/COLOR] ".xlsm")
    Cnt = 0
    While FoundName <> ""
        Cnt = Cnt + 1
        FoundName = Dir()
    Wend
    Wrk = ""
    If Cnt > 0 Then Wrk = " " [COLOR=#ff0000]&[/COLOR] (Cnt + 1)
    ActiveWorkbook.SaveAs Receiptpath + rdate + " RECEIPT " + WorkItemName + Wrk + ".xlsm"
    ActiveWorkbook.SaveAs Stimmelpath + rdate + " RECEIPT " + WorkItemName + Wrk + ".xlsm"