Sub MakeDir(dirname As String) 'функция проверки-создания
Dim i As Long, path As String
Do '
     i = InStr(i + 1, dirname & "\", "\")
     path = Left$(dirname, i - 1)
     If Right$(path, 1) <> ":" And Dir$(path, vbDirectory) = "" Then
         MkDir path
        MsgBox "Была создана необходимая для работы папка", 64, dirname
     End If
Loop Until i >= Len(dirname)

End Sub

On Error Resume Next
PathForFile$ = ThisWorkbook.path & "\" & Date & "\": MkDir PathForFile$
If Err.Number <> 75 And Err.Number <> 0 Then GoTo Ext
Err.Clear
On Error GoTo Ext
Randomize
On Error Resume Next
Kill PathForFile$
Err.Clear
On Error GoTo Ext
Open PathForFile$ For Output As #1
Print #1, tempstr
Close #1
Exit Sub
Ext:

Sub SaveSSP1()

     Dim PathForFile As String
     Dim NameWRD As String
     NameWRD = Sheets(1).Range("C22").Value & ".docx"
     PathForFile$ = ThisWorkbook.Path & "\" & Date & "\"
     Set FSO = CreateObject("Scripting.FileSystemObject")

     If Not FSO.FolderExists(PathForFile$) Then
         FSO.CreateFolder (PathForFile$)    '

     End If
     Set FSO = Nothing
     Sheets(7).Range("A1:E26").Copy
     Set AppWord = CreateObject("Word.Application")
     AppWord.Visible = True
     AppWord.Documents.Add.Range.PasteExcelTable False, False, False
     AppWord.ActiveDocument.SaveAs2 PathForFile$ & "\" & NameWRD, _
                    12, False, "", True, "", False, False, False, False, False, 14
     AppWord.ActiveDocument.Close

End Sub

Sub KillAllWord()
     Dim o As Object
     On Error GoTo GetObjectError
     Do While True
         Set o = GetObject(, "Word.Application")
         o.Quit
         Set o = Nothing
     Loop
NoMoreWord:
     On Error GoTo 0

     Exit Sub
      
GetObjectError:
     Debug.Print Err.Description
     Resume NoMoreWord
End Sub