Sub CopyToWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim i, j, m As Integer
Dim Ph, d As String
Dim fso As New FileSystemObject

Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open(Filename:=ThisWorkbook.Path & "\CRW.dot")
Application.ScreenUpdating = False

wdDoc.Bookmarks("имя1").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 3 ,  3 ).Text & " (" & ThisWorkbook.Worksheets("CrystalSphere").Cells( 4 ,  3 ).Text & ")")
wdDoc.Bookmarks("имя2").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 3 ,  3 ).Text & " (" & ThisWorkbook.Worksheets("CrystalSphere").Cells( 4 ,  3 ).Text & ")")
wdDoc.Bookmarks("имя3").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 3 ,  3 ).Text & " (" & ThisWorkbook.Worksheets("CrystalSphere").Cells( 4 ,  3 ).Text & ")")
wdDoc.Bookmarks("имя4").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 3 ,  3 ).Text & " (" & ThisWorkbook.Worksheets("CrystalSphere").Cells( 4 ,  3 ).Text & ")")
wdDoc.Bookmarks("дата1").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 8 ,  18 ).Value)
wdDoc.Bookmarks("дата2").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 8 ,  18 ).Value)
wdDoc.Bookmarks("дата3").Range.InsertAfter (ThisWorkbook.Worksheets("CrystalSphere").Cells( 8 ,  18 ).Value)

'cbr_data
'Размер требований
With wdDoc.Tables( 1 )
    For i =  1  To  4 
        For j =  1  To  4 
            .Cell(i, j) = ThisWorkbook.Worksheets("CBR_data").Cells(i +  7 , j +  1 ).Text
        Next j
    Next i
End With

'Регистрационные данные
With wdDoc.Tables( 2 )
    For i =  1  To  6 
        For j =  1  To  4 
            .Cell(i, j) = ThisWorkbook.Worksheets("CBR_data").Cells(i +  13 , j +  1 ).Text
        Next j
    Next i
End With

'сохранение
If Month(ThisWorkbook.Worksheets("CrystalSphere").Cells( 5 ,  3 )) <  10  Then: d = "0" & Month(ThisWorkbook.Worksheets("CrystalSphere").Cells( 5 ,  3 )): Else: d = Month(ThisWorkbook.Worksheets("CrystalSphere").Cells( 5 ,  3 ))
Ph = ThisWorkbook.Path & "\reports\" & Year(ThisWorkbook.Worksheets("CrystalSphere").Cells( 5 ,  3 )) & "\" & ThisWorkbook.Worksheets("CrystalSphere").Cells( 4 ,  3 ).Text & d & ".doc"

On Error Resume Next
fso.CreateFolder ThisWorkbook.Path & "\reports"
fso.CreateFolder ThisWorkbook.Path & "\reports\" & Year(ThisWorkbook.Worksheets("CrystalSphere").Cells( 5 ,  3 ))

wdDoc.SaveAs Filename:=Ph, FileFormat:=wdFormatDocument
UserForm1.Hide

Application.ScreenUpdating = True
MsgBox "создание отчета завершено"
wdApp.Visible = True

''wdDoc.Close SaveChanges:=True
''wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub