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! :doh:
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!! :clap: