Помогите пожалуйста чайнику с макросом, который мне необходим на работе, для заполнения бланков в Word путем копирования диапазона ячеек в Excel.
Уже весь форум облазил. Пробовал разные макросы и остановился на этом (ниже). Но в нем нет функции - "открыть уже созданный документ ворд и вставить скопированный диапазон в закладку, ну или пусть остается " в конце текста". Что не так?
Sub SelectionToDoc()
Dim objWord As Object
Const wdCollapseEnd = 0, wdCharacter = 1, wdNewBlankDocument = 0
' Найти открытое приложение Word (это может быть и Outlook, если в нем Word в качестве редактора)
On Error Resume Next
Set objWord = GetObject(, "Word.Application"
' Если Word-приложение не найдено, то создать новое
If Err Then
' Нужна вот эта функция, но с ней не работает макрос
Set objWord = objWrdApp.Documents.Open("C:\1.doc"
End If
objWord.Visible = True
' При ошибке - на выход! :-)
On Error GoTo exit_
' Если нет ни одного открытого Word-документа, то добавить новый
If objWord.Documents.Count = 0 Then objWord.Documents.Add
' Перейти в конец Word-документа
With objWord.ActiveDocument.Content
.Characters(.Characters.Count).Select
End With
' Добавть новый абзац в Word
objWord.Selection.TypeParagraph
' Cкопировать выделенный в Excel диапазон, вместо Selection можно указать и конкретный диапазон,
' например: Range("A3:B7" .Copy
Range("B2:I14" .Copy
' Вставить в Word
objWord.Selection.Paste
' Снять в Excel режим копирования
Application.CutCopyMode = False
' Активировать окно Microsoft Word (закомментировать строку ниже, если не нужно)
objWord.Tasks("Microsoft Word" .Activate
exit_:
' Освободить память, использованную обхектной (As Object) переменной
Set objWord = Nothing
' Сообщить об ошибке, если случится
If Err Then MsgBox Err.Description, vbCritical, "Ошибка в макросе SelectionToDoc"
End Sub
Уже весь форум облазил. Пробовал разные макросы и остановился на этом (ниже). Но в нем нет функции - "открыть уже созданный документ ворд и вставить скопированный диапазон в закладку, ну или пусть остается " в конце текста". Что не так?
Sub SelectionToDoc()
Dim objWord As Object
Const wdCollapseEnd = 0, wdCharacter = 1, wdNewBlankDocument = 0
' Найти открытое приложение Word (это может быть и Outlook, если в нем Word в качестве редактора)
On Error Resume Next
Set objWord = GetObject(, "Word.Application"
' Если Word-приложение не найдено, то создать новое
If Err Then
' Нужна вот эта функция, но с ней не работает макрос
Set objWord = objWrdApp.Documents.Open("C:\1.doc"
End If
objWord.Visible = True
' При ошибке - на выход! :-)
On Error GoTo exit_
' Если нет ни одного открытого Word-документа, то добавить новый
If objWord.Documents.Count = 0 Then objWord.Documents.Add
' Перейти в конец Word-документа
With objWord.ActiveDocument.Content
.Characters(.Characters.Count).Select
End With
' Добавть новый абзац в Word
objWord.Selection.TypeParagraph
' Cкопировать выделенный в Excel диапазон, вместо Selection можно указать и конкретный диапазон,
' например: Range("A3:B7"
.CopyRange("B2:I14"
.Copy' Вставить в Word
objWord.Selection.Paste
' Снять в Excel режим копирования
Application.CutCopyMode = False
' Активировать окно Microsoft Word (закомментировать строку ниже, если не нужно)
objWord.Tasks("Microsoft Word"
.Activateexit_:
' Освободить память, использованную обхектной (As Object) переменной
Set objWord = Nothing
' Сообщить об ошибке, если случится
If Err Then MsgBox Err.Description, vbCritical, "Ошибка в макросе SelectionToDoc"
End Sub
