Changing part of a workbook name and saving file as new name

I am trying to change a filename (YY number) before saving the workbook as a new file. Every filename has the format: "HXXX-XXX-XXX-YY Example Title"

YY is any number starting from 0 to infinity, where the YY always starts 14 characters into the string.

Is there any way to take the original filename (attempted in the code), change the YY number to the next consecutive number then SaveAs with the "new" file name?

Example:
Title Before: H019-018-072-2 Device Language AS
Expected Result: H019-018-072-3 Device Language AS

My code is partly there, but would I need to split the string?

Sub SaveAsNewFile1()
Dim filepath As String
Dim filename As String
Dim filepatharch As String
Dim filelist As String
Dim filedate As String
Dim filecount As Integer

'Set where to save and the file naming convention
filepath = "H:\BoM Drafts Macro\"
filename = ActiveWorkbook.Name

If InStr(filename, ".") > 0 Then
    Str1 = Left(filename, InStr(filename, ".") - 1)
End If

With CreateObject("Scripting.FileSystemObject")
    Debug.Print Mid$(.GetBaseName(Str1), 13)
End With

'"HXXX-XXX-XXX-.."& rest of name
filepatharch = "H:\BoM Drafts Macro\"'Do While Len(Dir(filepatharch & filename)) <> 0
    'filecount = filecount + 1
    'hfilename = "STR1"& filename
'Loop

Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs filename:= _
    "H:\BoM Drafts Macro\"& hfilename & ".xlsx"

ActiveWindow.Close

End Sub