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