Sub Import_Word()
    
Dim objWrdApp As Object, objWrdDoc As Object, wdRange As Object
Dim IsAppClose As Boolean
                
Application.ScreenUpdating = True
    
'пытаемся подключится к Word
    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
'если приложение закрыто - создаем новый экземпляр
        Set objWrdApp = CreateObject("Word.Application")
'сделать видимым
        objWrdApp.Visible = True
        IsAppClose = True 'Не знаю что это
    End If
    
    On Error GoTo 0
    If objWrdApp Is Nothing Then
        MsgBox "Не удалось подключиться к Word"
        Application.ScreenUpdating = True
        Exit Sub
    End If

'Открываем документ Word - документ "C:\макрос\Шаблон.doc"
'находится в папке с рабочей книгой
Set objWrdDoc = objWrdApp.Documents.Open("C:\макрос\Шаблон.doc")

'сохраняем файл шаблона с как "Расчет+дата.doc"
objWrdDoc.SaveAs ThisWorkbook.Path & "\Расчет " & Format(Now, "dd-mm-yy hh-mm") & ".doc"
    
'Перебираем именованые ячейки книги и сравниваем с метками в шаблоне, производим замену,
'если есть совпадения.
'Например. Значение ячейки с именем "Яч1" заменит метку в шаблоне {Яч1} по всему документу
Dim nName As Name
    For Each nName In ThisWorkbook.Names
    Set wdRange = objWrdDoc.Range
    wdRange.Find.ClearFormatting
    wdRange.Find.Replacement.ClearFormatting
      With wdRange.Find
          .text = "{" & nName.Name & "}"
          .Replacement.text = Range(nName).text
          .Forward = True
          .Wrap = 1 'wdFindContinue - не знаю что это
          .Format = False
          .MatchCase = False
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Execute Replace:=2 'wdReplaceAll - почемуто воспринимается как переменная и не работает :(
      End With
    Next nName
                


        
'Аналогичный перебор с листами книги. Таблица из листа {Лист1} должна заменить метку в шаблоне {Лист1}
Dim List As Worksheet
    For Each List In ThisWorkbook.Worksheets
'Чтобы в переборе участвовали только листы с фигурными скобками
        If InStr(List.Name, "{") > 0 Then
'Скопировали содержание листа
        ThisWorkbook.Worksheets(List.Name).UsedRange.Copy
'Поиск и замена
            With wdRange.Find
                .text = List.Name
                .Replacement.text = Selection.Paste    ' Что то делаю не так :(((
                .Forward = True
                .Wrap = 1 'wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2 'wdReplaceAll
            End With
        End If
    Next List





'закрываем документ Word с сохранением
objWrdDoc.Close True
'закрываем приложение Word - обязательно!
objWrdApp.Quit
'очищаем переменные Word - обязательно!
Set objWrdDoc = Nothing: Set objWrdApp = Nothing
    
End Sub