Из 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