Из Excel в Word

Sub MakeMemos()
'Создание заметок в Word с помощью автоматизации
   Dim WordApp As Object
   Dim Data As Range
   Dim Message As String
   Dim Records As Integer
   Dim i As Integer
   Dim Rebion As String, SalesAmt As String
   Dim SalesNum As String
   Dim SaveAsName As String
'Запуск Word и создание объекта(позднее связывание)
   Set WordApp = CreateObject("Word.Application")
'Информация с рабочего листа
   Set Data = Sheets(1).Range("A1")
   Message = Sheets(1).Range("E6")
'Циклический просмотр всех записей на листе 1
   Records = Application.CountA(Sheets(1).Range("A:A"))
   For i = 1 To Records
'     Обновление сообщения в строке состояния
      Application.StatusBar = "Обработка записи " & i
'     Назначение данных переменным
      Region = Data.Cells(i, 1).Value
      SalesNum = Data.Cells(i, 2).Value
      SalesAmt = Format(Data.Cells(i, 3).Value, "#,000")
'     Путь и имя файла
      SaveAsName = Application.DefaultFilePath & "\" & Region & ".doc"
      With WordApp
         .Documents.Add
         With .Selection
            .Font.Size = 14
            .Font.Bold = True
            .ParagraphFormat.Alignment = 1
            .TypeText Text:="Меморандум"
            .TypeParagraph
            .TypeParagraph
            .Font.Size = 12
            .ParagraphFormat.Alignment = 0
            .Font.Bold = False
            .TypeText Text:="Дата:" & vbTab & _
                Format(Date, "d mmmm,yyyy ")
            .TypeParagraph
            .TypeText Text:="Получатель:" & vbTab & _
               "Менеджер, " & Region
            .TypeParagraph
            .TypeText Text:="Отправитель:" & vbTab & _
               Application.UserName
            .TypeParagraph
            .TypeParagraph
            .TypeText Message
            .TypeParagraph
            .TypeParagraph
            .TypeText Text:="Количество проданных позиций:" _
               & vbTab & SalesNum
            .TypeParagraph
            .TypeText Text:="Сумма:" & vbTab & _
               Format(SalesAmt, "$ # ,# # 0 ")
         End With
         .ActiveDocument.SaveAs Filename:=SaveAsName
      End With
   Next i
'Удаление объекта
   WordApp.Quit
   Set WordApp = Nothing
   
End Sub