How to stop Overwrites in VBA Word

[AlyNeedsHelp]

I am very new to this, but I am attempting to try to have a 'submit button' in my survey, in word, to save to a specific file per submission.

The company I work for is trying to go paperless to some extent and I have been set to figure it out.

Each employee signs in on a sheet each day for covid, among other documents for other reasons.
I have so far gotten my code to allow me to have it save directly to a file, but it overwrites every time a new form is submitted.
How do I get this to stop?
I have pasted my code below to hopefully see where I've gone wrong.

Sub CommandButton1_Click()
Dim strNewFolderName As String
    strNewFolderName = "Covid Sheets " & (Day(Now) & " " & Month(Now())) & " " & Year(Now)
    If Len(Dir("Q:\Vault\Shop Forms\Covid Sheets" & strNewFolderName, vbDirectory)) = 0 Then
        MkDir ("Q:\Vault\Shop Forms\Covid Sheets" & strNewFolderName)
    End If
    Dim PathName As String
    PathName = ("Covid Sheets " & MonthName(Month(Now())) & " " & Year(Now))
    ActiveDocument.SaveAs FileName:="Q:\Vault\Shop Forms\Covid Sheets" & strNewFolderName & "" & Split(ActiveDocument.Name, "")(0) & ".doc", _
    FileFormat:=wdFormatDocument
End Sub

[gmayor]

You haven't gone wrong. You are using the same filename each time and that overwrites any existing file of the same name. You need a process to add an incrementing number to the name e.g.

Sub CommandButton1_Click()
Dim strNewFolderName As String
Dim strDocName As String
    strNewFolderName = "e:\Vault\Shop Forms\Covid Sheets " & (Day(Now) & " " & Month(Now())) & " " & Year(Now)
    CreateFolders strNewFolderName
    If ActiveDocument.path = "" Then
        strDocName = CStr(Split(ActiveDocument.Name, "")(0)) & ".doc"
    Else
        strDocName = FileNameUnique(strNewFolderName, ActiveDocument.Name, ".doc")
    End If
    ActiveDocument.SaveAs FileName:=strNewFolderName & "\" & strDocName, _
                          FileFormat:=wdFormatDocument

End Sub

Private Function FileNameUnique(strPath As String, _
                               strFileName As String, _
                               strExtension As String) As String
Dim lng_F As Long
Dim lng_Name As Long
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Do Until Right(strPath, 1) = "\"
        strPath = strPath & "\"
    Loop
    If InStr(1, strFileName, "\") > 0 Then
        strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
    End If
    strExtension = Replace(strExtension, Chr(46), "")
    lng_F = 1
    lng_Name = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lng_Name)
    Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        If Right(strFileName, 1) = ")" Then strFileName = Split(strFileName, "(")(0)
        strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
        lng_F = lng_F + 1
    Loop
    
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lng_PathSep = InStr(3, strPath, "\")
    If lng_PathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        If lng_PathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lng_PathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
            oFSO.createfolder Left(strPath, lng_PathSep)
        End If
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub

[gmayor]

Oops!
The line

strNewFolderName = "e:\Vault\Shop Forms\Covid Sheets " & (Day(Now) & " " & Month(Now())) & " " & Year(Now)

should read

strNewFolderName = "Q:\Vault\Shop Forms\Covid Sheets " &  (Day(Now) & " " & Month(Now())) & " " & Year(Now)

[AlyNeedsHelp]

Thank you! It works great!!