Сохранение файла в новую папку с уникальным именем

Option Explicit
 
Const WD_TEMPL = "РЕШЕНИЕ.dotx"
 
Sub Решение_неверный_грз()
 
Static wdApp As Object
Dim newFileName As String
Dim newFilePath As String
Dim wdDoc As Object
Dim x, кто_расматривает, номер_постановления, дата_вынесения, лицо_вынесшее_постановление, дата_жалобы, номер_жалобы, фио_рп, номер_постановления_2, дата_вынесения_2, лицо_вынесшее_постановление_2, фио_дп, дата_расмотр, дата_расмотр_2, фио, дата_наруш, время_наруш, место, кам, номер_кам, грз, марка, скорость_тс, перевышение, разрешенная, фио_2, фио_3, номер_постановления_3, дата_вынесения_3, лицо_вынесшее_постановление_3, фио_дп_2, часть, статья, сумма, начальник
Set x = ActiveSheet
Sheets("Ошибка грз").Select
 
кто_расматривает = Cells(58, 2)
номер_постановления = Cells(3, 7)
дата_вынесения = Cells(17, 4)
лицо_вынесшее_постановление = Cells(59, 2)
дата_жалобы = Cells(3, 6)
номер_жалобы = Cells(3, 4)
фио_рп = Cells(9, 4)
номер_постановления_2 = Cells(3, 7)
дата_вынесения_2 = Cells(17, 4)
лицо_вынесшее_постановление_2 = Cells(59, 2)
фио_дп = Cells(10, 4)
дата_расмотр = Cells(3, 10)
дата_расмотр_2 = Cells(3, 10)
фио = Cells(61, 3)
 
x.Select
On Error Resume Next
x = wdApp.Name
If Err Then
Err.Clear
Set wdApp = GetObject(, "word.application")
If Err Then
    Err.Clear
    Set wdApp = CreateObject("word.application")
    If Err Then
    MsgBox "Невозможно открыть Word", vbCritical
    Exit Sub
    End If
End If
End If
With wdApp
.Visible = True
x = .Documents.Count
Set wdDoc = .Documents.Add(ThisWorkbook.Path & "\Шаблоны\неверный_грз" & WD_TEMPL)
If .Documents.Count <= x Then
    MsgBox "Не найден шаблон " & WD_TEMPL, vbCritical
    Exit Sub
End If
End With
With wdDoc
.Bookmarks("кто_расматривает").Range.Text = кто_расматривает
.Bookmarks("номер_постановления").Range.Text = номер_постановления
.Bookmarks("дата_вынесения").Range.Text = дата_вынесения
.Bookmarks("лицо_вынесшее_постановление").Range.Text = лицо_вынесшее_постановление
.Bookmarks("дата_жалобы").Range.Text = дата_жалобы
.Bookmarks("номер_жалобы").Range.Text = номер_жалобы
.Bookmarks("фио_рп").Range.Text = фио_рп
.Bookmarks("номер_постановления_2").Range.Text = номер_постановления
.Bookmarks("дата_вынесения_2").Range.Text = дата_вынесения_2
.Bookmarks("лицо_вынесшее_постановление_2").Range.Text = лицо_вынесшее_постановление_2
.Bookmarks("фио_дп").Range.Text = фио_дп
.Bookmarks("дата_расмотр").Range.Text = дата_расмотр
.Bookmarks("дата_расмотр_2").Range.Text = дата_расмотр_2
.Bookmarks("фио").Range.Text = фио
 
End With
wdApp.Activate
 
End Sub

Dim iPath$
iPath = ThisWorkbook.Path & "\" & ФИО & "\"
If Dir(iPath, vbDirectory) = "" Then MkDir iPath
 
With wdDoc
     'Здесь перечисляются все Ваши закладки .Bookmarks 
 
     .SaveAs iPath & Replace(WD_TEMPL, ".dotx", ".docx") 'Возможно нужно указать FileFormat
     .Close -1 'wdSaveChanges = -1
End With