Vba excel создание файла word

Создание нового документа Word или открытие существующего из кода VBA Excel. Методы Documents.Add и Documents.Open. Сохранение и закрытие документа.

Работа с Word из кода VBA Excel
Часть 2. Создание и открытие документов Word
[Часть 1] [Часть 2] [Часть 3] [Часть 4] [Часть 5] [Часть 6]

Новый документ Word создается из кода VBA Excel с помощью метода Documents.Add:

Sub Test1()

Dim myWord As New Word.Application

Dim myDocument As Word.Document

Set myDocument = myWord.Documents.Add

myWord.Visible = True

End Sub

Переменную myDocument можно объявить с типом Object, но тогда не будет ранней привязки к типу Word.Document и подсказок при написании кода (Auto List Members).

Открытие существующего документа

Существующий документ Word открывается из кода VBA Excel с помощью метода Documents.Open:

Sub Test2()

Dim myWord As New Word.Application

Dim myDocument As Word.Document

Set myDocument = _

myWord.Documents.Open(«C:Документ1.docx»)

myWord.Visible = True

End Sub

Замените в этой процедуре строку «C:Документ1.docx» на адрес своего файла.

Подключение к открытому документу

Присвоение переменной ссылки на существующий экземпляр Word.Application осуществляется в VBA Excel с помощью функции GetObject:

Sub Test3()

Dim myWord As Object, myDoc As Word.Document

On Error GoTo Instr

    Set myWord = GetObject(, «Word.Application»)

    Set myDoc = myWord.Documents(«Документ1.docx»)

    myDoc.Range.InsertAfter «Добавляем новый текст, подтверждающий подключение к открытому документу.»

Exit Sub

Instr:

    MsgBox «Произошла ошибка: « & Err.Description

End Sub

Если открытого приложения Word нет, выполнение функции GetObject приведет к ошибке. Также произойдет ошибка, если не будет найден указанный документ (в примере — «Документ1.docx»).

Сохранение и закрытие документа

Сохранение нового документа

Чтобы сохранить из кода VBA Excel новый документ Word, используйте метод SaveAs2 объекта Document:

myDocument.SaveAs2 («C:Документ2.docx»)

Замените «C:Документ2.docx» на путь к нужному каталогу с именем файла, под которым вы хотите сохранить новый документ.

Сохранение изменений в открытом документа

Сохраняйте изменения в существующем документе с помощью метода Document.Save или параметра SaveChanges метода Document.Close:

‘Сохранение изменений документа

myDocument.Save

‘Сохранение изменений документа

‘при закрытии

myDocument.Close ‘по умолчанию True

myDocument.Close True

myDocument.Close wdSaveChanges

‘Закрытие документа без

‘сохранения изменений

myDocument.Close False

myDocument.Close wdDoNotSaveChanges

Закрытие любого сохраненного документа

Метод Document.Close закрывает документ, но не приложение. Если работа с приложением закончена, оно закрывается с помощью метода Application.Quit.

Источник

Using Excel VBA to create Microsoft Word documents

In these examples, we generate Microsoft Word Documents with various formatting features using
the Microsoft Excel VBA scripting language. These techniques can have many useful applications.
For instance if you have a list of data like a price or product list in Excel that you want to present
in a formatted Word Document, these techniques can prove useful.

In these examples, we assume the reader has at least basic knowledge of VBA, so we will not
go over basics of creating and running scripts. This code has been tested on Microsoft Word and Excel
2007. Some changes may be required for other versions of Word and Excel.

Writing to Word
Inserting a Table of Contents
Inserting Tabs
Inserting Tables
Inserting Bullet List
more on Inserting Tables
Multiple Features

Function that demonstrates VBA writing to a Microsoft Word document

The following code illustrates the use of VBA Word.Application object and related properties.
In this example, we create a new Word Document add some text.

    'In Tools > References, add reference to "Microsoft Word XX.X Object Library" before running.
	
    'Early Binding
    Dim wdApp As Word.Application
    Set wdApp = New Word.Application
    
    'Alternatively, we can use Late Binding
    'Dim wdApp As Object
    'Set wdApp = CreateObject("word.Application")
        
    With wdApp
        .Visible = True
        .Activate
        .Documents.Add
        
        With .Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Font.Bold = True
            .Font.Name = "arial"
            .Font.Size = 14
            .TypeText ("My Heading")
            .TypeParagraph            
        End With
    End With

Some VBA Vocabulary

ParagraphFormat
Represents all the formatting for a paragraph.

output in MS Word:

Inserting a Table of Contents into Word Document using Excel VBA

In this example, we generate a Table of Contents into a Word Document using Excel VBA

Sub sAddTableOfContents()
    
    Dim wdApp As Word.Application
    Set wdApp = New Word.Application
	
    'Alternatively, we can use Late Binding
    'Dim wdApp As Object
    'Set wdApp = CreateObject("word.Application")
    
    Dim wdDoc As Word.Document
    Set wdDoc = wdApp.Documents.Add
    
    ' Note we define a Word.range, as the default range wouled be an Excel range!
    Dim myWordRange As Word.range
    Dim Counter As Integer
    
    wdApp.Visible = True
    wdApp.Activate
    
    'Insert Some Headers
    With wdApp
        For Counter = 1 To 5
            .Selection.TypeParagraph
            .Selection.Style = "Heading 1"
            .Selection.TypeText "A Heading Level 1"
            .Selection.TypeParagraph
            .Selection.TypeText "Some details"
        Next
    End With

    ' We want to put table of contents at the top of the page
	Set myWordRange = wdApp.ActiveDocument.range(0, 0)
    
    wdApp.ActiveDocument.TablesOfContents.Add _
     range:=myWordRange, _
     UseFields:=False, _
     UseHeadingStyles:=True, _
     LowerHeadingLevel:=3, _
     UpperHeadingLevel:=1

End Sub

Some VBA Vocabulary

ActiveDocument.TablesOfContents.Add
The TablesOfContents property to return the TablesOfContents collection.
Use the Add method to add a table of contents to a document.

Some TablesOfContents Parameters

Range The range where you want the table of contents to appear. The table of contents replaces the range, if the range isn’t collapsed.

UseHeadingStyles True to use built-in heading styles to create the table of contents. The default value is True.

UpperHeadingLevel The starting heading level for the table of contents. Corresponds to the starting value used with the o switch for a Table of Contents (TOC) field. The default value is 1.

LowerHeadingLevel The ending heading level for the table of contents. Corresponds to the ending value used with the o switch for a Table of Contents (TOC) field. The default value is 9.

output Word Table in MS Word:

Write Microsoft Word Tabs

A function that writes tabbed content to a Microsoft Word Document. Note in each iteration, we change the
value of the leader character (characters that are inserted in the otherwise blank area created by the tab).

Public Sub sWriteMicrosoftTabs()

    'In Tools > References, add reference to "Microsoft Word XX.X Object Library" before running.
    
    'Early Binding
    Dim wdApp As Word.Application
    Set wdApp = New Word.Application
    
    'Alternatively, we can use Late Binding
    'Dim wdApp As Object
    'Set wdApp = CreateObject("word.Application")
        
    With wdApp
        .Visible = True
        .Activate
        .Documents.Add
    
        For Counter = 1 To 3
            .Selection.TypeText Text:=Counter & " - Tab 1 "
            
            ' position to 2.5 inches
            .Selection.Paragraphs.TabStops.Add Position:=Application.InchesToPoints(2.5), _
                Leader:=Counter, Alignment:=wdAlignTabLeft
            
            .Selection.TypeText Text:=vbTab & " - Tab 2 "
            
            ' position to 5 inches
            .Selection.Paragraphs.TabStops.Add Position:=Application.InchesToPoints(5), _
                Leader:=Counter, Alignment:=wdAlignTabLeft
            
            .Selection.TypeText Text:=vbTab & " - Tab 3 "
                    
            .Selection.TypeParagraph
        Next Counter
        
    End With
End Sub

Some VBA Vocabulary

.TabStops.Add Use the TabStops property to return the TabStops collection. In the example above,
nprogram adds a tab stop positioned at 0, 2.5 and 5 inches.

output in MS Word:

Write Microsoft Word Tables

In this example, we generate a Microsoft Table using Excel VBA

Sub sWriteMSWordTable ()
 
    'In Tools > References, add reference to "Microsoft Word XX.X Object Library" before running.
    
    'Early Binding
    Dim wdApp As Word.Application
    Set wdApp = New Word.Application
    
    'Alternatively, we can use Late Binding
    'Dim wdApp As Object
    'Set wdApp = CreateObject("word.Application")
        
    With wdApp
        .Visible = True
        .Activate
        .Documents.Add
        
        With .Selection
        
            .Tables.Add _
                    Range:=wdApp.Selection.Range, _
                    NumRows:=1, NumColumns:=3, _
                    DefaultTableBehavior:=wdWord9TableBehavior, _
                    AutoFitBehavior:=wdAutoFitContent
            
            For counter = 1 To 12
                .TypeText Text:="Cell " & counter
                If counter <> 12 Then
                    .MoveRight Unit:=wdCell
                End If
            Next
        
        End With
        
    End With

End Sub

Some VBA vocabulary

Table.AddTable object that represents a new, blank table added to a document.

Table.Add properties

Range The range where you want the table to appear. The table replaces the range, if the range isn’t collapsed.

NumRows The number of rows you want to include in the table.

NumColumns The number of columns you want to include in the table.

DefaultTableBehavior Sets a value that specifies whether Microsoft Word automatically resizes cells in tables to fit the cells� contents (AutoFit). Can be either of the following constants: wdWord8TableBehavior (AutoFit disabled) or wdWord9TableBehavior (AutoFit enabled). The default constant is wdWord8TableBehavior.

AutoFitBehavior Sets the AutoFit rules for how Word sizes tables. Can be one of the WdAutoFitBehavior constants.

output in MS Word:

Write Microsoft Word bullet list

In this example, we write with bullet list and outline numbers with Excel VBA

    'In Tools > References, add reference to "Microsoft Word XX.X Object Library" before running.
    
    'Early Binding
    Dim wdApp As Word.Application
    Set wdApp = New Word.Application
    
    'Alternatively, we can use Late Binding
    'Dim wdApp As Object
    'Set wdApp = CreateObject("word.Application")
    
    With wdApp
        .Visible = True
        .Activate
        .Documents.Add
        ' turn on bullets
        .ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
        .Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=.ListGalleries(wdBulletGallery).ListTemplates(1), _
            continuepreviouslist:=False, applyto:=wdListApplyToWholeList, defaultlistbehavior:=wdWord9ListBehavior
        
        With .Selection
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
            .Font.Bold = False
            .Font.Name = "Century Gothic"
            .Font.Size = 12
            .TypeText ("some details")
            .TypeParagraph
            .TypeText ("some details")
            .TypeParagraph
        End With
        
        ' turn off bullets
        .Selection.Range.ListFormat.RemoveNumbers wdBulletGallery
        
        With .Selection
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
            .TypeText ("some details")
            .TypeParagraph
            .TypeText ("some details")
            .TypeParagraph
            
        End With
        
        ' turn on outline numbers
        .ListGalleries(wdOutlineNumberGallery).ListTemplates(1).Name = ""
        .Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=.ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
            continuepreviouslist:=False, applyto:=wdListApplyToWholeList, defaultlistbehavior:=wdWord9ListBehavior
        
        With .Selection
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
            .TypeText ("some details")
            .TypeParagraph
            .TypeText ("some details")
            
        End With
        
    End With

output in MS Word:

Another example of Writing Tables to Microsoft Word

In this example we will create a word document with 20 paragraphs. Each paragraph will have a header with a header style element

    
   'In Tools > References, add reference to "Microsoft Word XX.X Object Library" before running.
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document

    Set wdApp = New Word.Application
    wdApp.Visible = True
    
    
    Dim x As Integer
    Dim y As Integer
    
    wdApp.Visible = True
    wdApp.Activate
    wdApp.Documents.Add
            
    wdApp.ActiveDocument.Tables.Add Range:=wdApp.Selection.Range, NumRows:=2, NumColumns:= _
        2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
                
    With wdApp.Selection.Tables(1)
        If .Style <> "Table Grid" Then
            .Style = "Table Grid"
        End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
    End With
            
    With wdApp.Selection
        
        For x = 1 To 2
            ' set style name
            .Style = "Heading 1"
            .TypeText "Subject" & x
            .TypeParagraph
            .Style = "No Spacing"
            For y = 1 To 20
                .TypeText "paragraph text "
            Next y
            .TypeParagraph
        Next x
    
        ' new paragraph
        .TypeParagraph
        
        ' toggle bold on
        .Font.Bold = wdToggle
        .TypeText Text:="show some text in bold"
        .TypeParagraph
        
        'toggle bold off
        .Font.Bold = wdToggle
        .TypeText "show some text in regular front weight"
        .TypeParagraph
        
        
    End With

Some VBA vocabulary

TypeText

Inserts specified text at the beginning of the current selection. The selection is turned into an insertion point at the end of the inserted text.
If Options.ReplaceSelection = True then the original selection will be replaced. This behaves exactly the same as typing some text at the keyboard.

TypeParagraph

Insert a new blank paragraph. The selection is turned into an insertion point after the inserted paragraph mark. If Options.ReplaceSelection = True then the original selection will be replaced. This behaves exactly the same as pressing the Enter key.

output in MS Word:

Generating a Word table with VBA
	'In Tools > References, add reference to "Microsoft Word XX.X Object Library" before running.

	Dim wdApp As Word.Application
	Dim wdDoc As Word.Document
	Dim r As Integer

	Set wdApp = CreateObject("Word.Application")
	wdApp.Visible = True

	Set wdDoc = wdApp.Documents.Add
	wdApp.Activate

	Dim wdTbl As Word.Table
	Set wdTbl = wdDoc.Tables.Add(Range:=wdDoc.Range, NumRows:=5, NumColumns:=1)

	With wdTbl

		.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
		.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
		.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
		.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
		.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
		.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
		
		For r = 1 To 5
			.Cell(r, 1).Range.Text = ActiveSheet.Cells(r, 1).Value
		Next r
	End With

output in MS Word:

Option Explicit
Dim wdApp As Word.Application
 
Sub extractToWord()

   'In Tools > References, add reference to "Microsoft Word 12 Object Library" before running.
   
    Dim lastCell
    Dim rng As Range
    Dim row As Range
    Dim cell As Range
    Dim arrayOfColumns
    arrayOfColumns = Array("", "", "", "", "", "", "", "", "", "", "", "", "", "", "")
    Dim thisRow As Range
    Dim thisCell As Range
    Dim myStyle As String
    
    ' get last cell in column B
    lastCell = getLastCell()
    
    Set rng = Range("B2:H" & lastCell)
    
    'iterate through rows
    For Each thisRow In rng.Rows
            
        'iterate through cells in row row
        For Each thisCell In thisRow.Cells

            If thisCell.Value = arrayOfColumns(thisCell.Column) Or thisCell.Value = "" Then
            ' do nothing
                ''frWriteLine thisCell.Value, "Normal"
                ''frWriteLine arrayOfColumns(thisCell.Column), "Normal"
                  If thisCell.Value = arrayOfColumns(thisCell.Column) Or thisCell.Value = "" Then
                  End If
                  
            Else
                myStyle = "Normal"
                Select Case thisCell.Column
                    Case 2
                        myStyle = "Heading 1"
                    Case 3
                        myStyle = "Heading 2"
                    Case 4
                        myStyle = "Heading 3"
                    Case Is > 5
                        myStyle = "Normal"
                    
                End Select
                    
                frWriteLine thisCell.Value, myStyle
            End If
        
        arrayOfColumns(thisCell.Column) = thisCell.Value
    
      Next thisCell
    Next thisRow
    
End Sub

Public Function getLastCell() As Integer

    Dim lastRowNumber As Long
    Dim lastRowString As String
    Dim lastRowAddress As String
         
    With ActiveSheet
        getLastCell = .Cells(.Rows.Count, 2).End(xlUp).row
    End With
    
End Function

Public Function frWriteLine(someData As Variant, myStyle As String)
    
    If wdApp Is Nothing Then
        
        Set wdApp = New Word.Application
        With wdApp
            .Visible = True
            .Activate
            .Documents.Add
        End With
            
    End If
    
    With wdApp
        
        With .Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Style = myStyle
            .TypeText (someData)
            .TypeParagraph
        End With
    End With
    
End Function

output in MS Word:

Источник

bizard, сначала делайте код в программе Word.
Когда ставите точку, то появляются члены, которые есть у объекта. Если среди членов нет нужного, значит у объекта нет этого члена. Есть случаи, что не все члены появляются после того, как поставишь точку, но такое редко бывает.

TypeParagraph — является членом объекта Selection. Если вы перейдёте в программу Word, октроете программу VBA, введёте ActiveDocument и поставите точку, то во всплывающей подсказке не будет TypeParagraph. Это означает, что у объекта ActiveDocument нет члена TypeParagraph (могут быть исключения — член не появляется, но есть, но это бывает редко).

Здесь:

Visual Basic 
1

ActiveDocument.Content.Font.Size = 11

вы используете ActiveDocument, а должны использовать oDocument, т.к. вся работа у вас из Excel в программе Word ведётся через две переменные: oWord и oDocument. Других слов ваш код не понимает, в т.ч. не понимает слова ActiveDocument.

Источник
 

khmelae

Пользователь

Сообщений: 6
Регистрация: 13.01.2017

#1

13.01.2017 03:02:19

Здравствуйте!

Есть макрос Excel который создает документ Word по шаблону. Необходимо внести изменения в код макроса таким образом чтобы:
1) Шаблоны хранились в папке «ШАБЛОНЫ (нужно чтобы хранились здесь)»
2) Готовые Договора сохранялись в папку «ДОГОВОРА (нужно чтобы сохранялись сюда)»
При этому если перемещается вся папка «CreateWordDocuments», в которой хранится файл с макросом «договор» и папки «ШАБЛОНЫ (нужно чтобы хранились здесь)» , «ДОГОВОРА (нужно чтобы сохранялись сюда)», маршрут должен подстраиваться под расположение файл с макросом «договор»

Пример прилагаю.

Заранее спасибо за помощь:)

Код 
Const ИмяФайлаШаблона = "шаблон.dot"
Const КоличествоОбрабатываемыхСтолбцов = 11
Const РасширениеСоздаваемыхФайлов = ".doc"
Sub СформироватьДоговоры2()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "C").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(3)) & " " & Trim$(.Cells(4)) & " " & Trim$(.Cells(5))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
        End With
    Next row
    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub

Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Договоры, сформированные " & Get_Now)
    MkDir NewFolderName
End Function
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

Прикрепленные файлы

  • CreateWordDocuments.rar (63.04 КБ)
 

khmelae

Пользователь

Сообщений: 6
Регистрация: 13.01.2017

#2

15.01.2017 02:58:16

Доброго всем времени суток!
После 4 часов проб и ошибок у меня получилось найти решение проблем с сохранением файла в нужное место. Все работает делюсь кодом макроса, может быть пригодится Вам.

Но возникли две новые трудности:
1) Как сделать так чтобы файл Word после сохранения открывался автоматически
тут у меня есть понимание что нужно внести коррективы в строку
WD.SaveAs Filename: WD.Close False: DoEvents
, но чтобы я не делал файл не открываются автоматически:

2) Как сохранить файл в формате PDF а не DOC
тут тоже есть догадка что нужно использовать метод ExportAsFixedFormat, но я не понимаю как его правильно применить.

Заранее спасибо за помощь:)

Код 
Const ИмяФайлаШаблона = "ШАБЛОНЫ/шаблон2.dot"
Const ИмяФайлаДоговора = "ДОГОВОРА/Договоры"
Const КоличествоОбрабатываемыхСтолбцов = 11
Const РасширениеСоздаваемыхФайлов = ".doc"Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    ПутьДоговора = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора)
    'НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "C").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(3)) & " " & Trim$(.Cells(4)) & " " & Trim$(.Cells(5) & Get_Now)
            Filename = ПутьДоговора & ФИО & РасширениеСоздаваемыхФайлов            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            'WD.PrintOut: WD.Close False: DoEvents печать без сохранения
            p = p + a
        End With
    Next row    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit True: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub




'Function NewFolderName() As String
   ' NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора & Get_Now)
   ' MkDir NewFolderName
'End FunctionFunction Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

Прикрепленные файлы

  • CreateWordDocuments_.rar (45.49 КБ)

Изменено: khmelae — 15.01.2017 02:59:58
 

The_Prist

Пользователь

Сообщений: 14182
Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

#3

15.01.2017 10:55:22

Цитата
khmelae написал:
использовать метод ExportAsFixedFormat, но я не понимаю как его правильно применить

записать в Word сохранение файла в PDF. Будет готовый код.

Цитата
khmelae написал:
чтобы файл Word после сохранения открывался автоматически

достаточно его просто не закрывать, я думаю. В этой строке:
WD.SaveAs Filename: WD.Close False: DoEvents
просто удалите
WD.Close False:

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

 

khmelae

Пользователь

Сообщений: 6
Регистрация: 13.01.2017
The_Prist

 спасибо за Ваш ответ. К сожалению просто удаление «WD.Close False: » не помогает сохраненные файлы не открываются автоматически. я уже попробовал разные варианты
1) WD.SaveAs Filename: WD.Open True: DoEvents   ‘сохранить и открыть
2) WD.Open Filename: DoEvents ‘открыть без сохранения
Но увы ничего не работает(((

C сохранением в PDF тоже не выходит, по Вашему совету сделал запись макроса «сохранение файла DOC в PDF». Попытался по подобию сделать, но ничего не получилось(((
1) WD.ExportAsFixedFormat OutputFilename: ExportFormat: wdExportFormat , PDFOpenAfterExport:=True
2) WD.ExportAsFixedFormat Filename: WD.Close False: DoEvents



Пока мой метод проб и ошибок не приносит результата…
 

The_Prist

Пользователь

Сообщений: 14182
Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

#5

16.01.2017 10:42:38

Цитата
khmelae написал:
сохраненные файлы не открываются

Они вообще у Вас создаются? Если каждый файл не закрывать — то он останется открытым, что приведет ровно к тому же эффекту, что закрыть-открыть. Поэтому приведенное мной решение работать должно без проблем, если только у Вас не возникает где-то раньше ошибка кода. Приведите код полностью как Вы там чего изменили.

Строка сохранения в PDF у Вас не рабочая — ознакомьтесь со статьей:

Как из Excel обратиться к другому приложению

Потому что нет у Excel понятия, что такое wdExportFormat. И то ли у Вас опечатка, то ли там знака равно после двоеточия не хватает. Выглядеть в итоге должно как-то так:

Код 
WD.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=17

только Filename должно так же отдельно формироваться для PDF, чтобы формат был именно .pdf, а не .doc. Т.е. надо создать доп.переменную, такую же как Filename и назначать ей значение. После строки:

Код 
Filename = ПутьДоговора & ФИО & РасширениеСоздаваемыхФайлов

записать еще одну:

Код 
FilenamePDF = ПутьДоговора & ФИО & ".pdf"

и для сохранения в PDF использовать её:

Код 
WD.ExportAsFixedFormat OutputFileName:=FilenamePDF, ExportFormat:=17

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

 

RAN

Пользователь

Сообщений: 7091
Регистрация: 21.12.2012

#6

16.01.2017 11:00:51

Цитата
khmelae написал:
но чтобы я не делал файл не открываются автоматически

Он открывается, только в скрытом режиме.
Отобразите word на экране

Код 
 WA.Visible = True
 

khmelae

Пользователь

Сообщений: 6
Регистрация: 13.01.2017

#7

17.01.2017 00:21:46

Добрый вечер!
Большое спасибо за помощь

The_Prist

.
Вопрос с сохранением в формате .pdf решен, все работает. рабочий код см. ниже. Было достаточно внести два изменения:
…
Const РасширениеСоздаваемыхФайлов = «.pdf»
…
WD.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=17 ‘ сохранение в pdf
WD.Close False: DoEvents ‘ закрытие файла
…

Код 
Const ИмяФайлаШаблона = "ШАБЛОНЫ/1401-1.dotx"
Const ИмяФайлаДоговора = "ПЕЧАТНЫЕ ФОРМЫ/1401-1"
Const КоличествоОбрабатываемыхСтолбцов = 134
Const РасширениеСоздаваемыхФайлов = ".pdf"
Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    ПутьДоговора = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора)
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "DA").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            НазваниеФайла = " " & Trim$(.Cells(105)) & " " & Get_Now
            Filename = ПутьДоговора & НазваниеФайла & РасширениеСоздаваемыхФайлов
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", НазваниеФайла
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", НазваниеФайла
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", НазваниеФайла, " "
            WD.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=17 ' сохранение в pdf
            'WD.SaveAs Filename: WD.Close False: DoEvents
            'WD.PrintOut: WD.Close False: DoEvents 'печать без сохранения
            WD.Close False: DoEvents
            p = p + a
        End With
    Next row
    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit True: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & ПутьДоговора
    MsgBox msg, vbInformation, "Готово"
    
End Sub

'Function NewFolderName() As String
   ' NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора & Get_Now)
   ' MkDir NewFolderName
'End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

Изменено: khmelae — 17.01.2017 00:25:51
 

khmelae

Пользователь

Сообщений: 6
Регистрация: 13.01.2017

#8

17.01.2017 01:26:42

Цитата
The_Prist написал:
Они вообще у Вас создаются?

Да создаются, я прикрепил вложение можете проверить.

По вопросу автоматического открытия / не закрытия сохраненного документа пока решения не нашел

The_Prist

.  Ваш вариант с удалением из кода «WD.Close False:» кажется логичным и правильным, но почему то не работает.
У меня есть одна догадка, суть работы макроса заключается в открытии файла шаблона DOT замене необходимых полей и сохранением файлов в формате DOС. При этом насколько я понимаю в процессе работы макроса сами созданные файлы DOС не открываются. Поэтому может быть эту проблему можно решить через открытие созданных документов DOС, но как правильно это сделать для меня пока не ясно(((

Цитата
RAN написал:
Он открывается, только в скрытом режиме.
Отобразите word на экране
Код ? 1WA.Visible = True

RAN я не совсем понимаю куда можно применить данный метод «WA.Visible = True «

Код 
Const ИмяФайлаШаблона = "ШАБЛОНЫ/шаблон2.dot"
Const ИмяФайлаДоговора = "ДОГОВОРА/Договоры"
Const КоличествоОбрабатываемыхСтолбцов = 11
Const РасширениеСоздаваемыхФайлов = ".doc"
Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    ПутьДоговора = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора)
    'НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "C").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(3)) & " " & Trim$(.Cells(4)) & " " & Trim$(.Cells(5) & Get_Now)
            Filename = ПутьДоговора & ФИО & РасширениеСоздаваемыхФайлов
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: DoEvents ' сохранить и открыть/незакрывать
            'WD.SaveAs Filename: WD.Close False: DoEvents ' сохранить и закрыть
            'WD.PrintOut: WD.Close False: DoEvents ' печать без сохранения
            p = p + a
        End With
    Next row
    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit True: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub





'Function NewFolderName() As String
   ' NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора & Get_Now)
   ' MkDir NewFolderName
'End Function
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

Прикрепленные файлы

  • CreateWordDocuments2.rar (37.92 КБ)

Изменено: khmelae — 17.01.2017 01:35:39
 

Logistic

Пользователь

Сообщений: 741
Регистрация: 03.01.2013
khmelae

, а что нужно изменить в коде ,что бы можно было формировать  один договор ,выделили в таблице  ячейку «Прізвище» Дзюба и получили договор по конкретной Фамилии.
 

The_Prist

Пользователь

Сообщений: 14182
Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

#10

17.01.2017 10:32:17

Цитата
khmelae написал:
в процессе работы макроса сами созданные файлы DOС не открываются

открываются. И даже по коду видно, что открываются, заполняются и далее СОХРАНЯЮТСЯ КАК. А это значит, что они остаются открытыми. Об этом же говорит строка WD.Close, т.к. если бы они не были открыты — зачем их закрывать?
Просто, вполне очевидно, что Вам надо еще убрать строку WA.Quit. Это закрытие Word-а полностью. А вместе с ним, естественно, закрываются и все документы.

Цитата
khmelae написал:
не совсем понимаю куда можно применить данный метод «WA.Visible = True «

сразу после строки:

Код 
Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

 

khmelae

Пользователь

Сообщений: 6
Регистрация: 13.01.2017

#11

18.01.2017 00:40:11

Ооо то что надо спасибо

The_Prist

, теперь я понял как применить идею

RAN

, ему тоже спасибо за помощь.

И так позволю себе подвести промежуточные итоги по улучшению данного макроса. Пример подкрепляю к данному сообщению, код макроса с различными вариантами его работы выкладываю ниже.

Цитата
Logistic написал:
а что нужно изменить в коде ,что бы можно было формировать  один договор ,выделили в таблице  ячейку «Прізвище» Дзюба и получили договор по конкретной Фамилии.

Logistic

я к сожалению не так хорошо разбираюсь в написании макросов чтобы, так просто и легко написать Вам изменение для формирования договора по выделенной ячейки, могу сказать одно что это точно можно реализовать, т.к. я видел похожие решения на др. форумах, но как реализовать конкретно для этого макроса я не подскажу. Попробуйте обратится к Богу Excel

The_Prist

;), он думаю сможет подсказать идеи.
Но я могу предложить рабоче-крестьянский вариант выполнения Вашей

Logistic

задачи без внесения изменений в данный макрос. Как вариант можно использовать формулу ВПР и дополнительный столбец с отметкой какую строку нужно сформировать как договор, это если надо сформировать только один договор из списка (пример во вложении). Если же Вам необходимо сформировать несколько договоров то можно использовать ВПР + массив. Если не разберетесь пишите ;)

Код 
Const ИмяФайлаШаблона = "ШАБЛОНЫ/шаблон2.dot"
Const ИмяФайлаДоговора = "ДОГОВОРА/Договоры"
Const КоличествоОбрабатываемыхСтолбцов = 19
Const РасширениеСоздаваемыхФайлов = ".doc"
Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    ПутьДоговора = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора)
    'НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "K").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
    WA.Visible = True ' отобразить Word
    
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(11)) & " " & Trim$(.Cells(12)) & " " & Trim$(.Cells(13) & Get_Now)
            Filename = ПутьДоговора & ФИО & РасширениеСоздаваемыхФайлов
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 11 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: 'сохранить созданый документ
            'или
            'WD.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=17 ' сохранение в pdf
            'или
            'WD.PrintOut:'печать без сохранения
            
            'WD.Close False: DoEvents 'закрыть созданый документ Word
            
            p = p + a
        End With
    Next row
    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    'WA.Quit True: 'закрыть приложение Word
    pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub





'Function NewFolderName() As String
   ' NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора & Get_Now)
   ' MkDir NewFolderName
'End Function
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

 

Прикрепленные файлы

  • CreateWordDocuments3.rar (27.75 КБ)

Изменено: khmelae — 18.01.2017 00:43:20
 

msdmo

Пользователь

Сообщений: 4
Регистрация: 29.02.2016

Доброго времени суток.
Подскажите пожалуйста, какие параметры надо изменить в коде макроса, если мне надо добавить слева один столбик и сверху 8 строк?
Поменял в строках:
r = Cells(Rows.Count, «B«).End(xlUp).row: rc = r — 10
For Each row In ActiveSheet.Rows(«11:» & r)
ФИО = Trim$(.Cells(2)) & » » & Trim$(.Cells(3)) & » » & Trim$(.Cells(4))
Вордовские документы формируются, но данные не вставляются.

Прикрепленные файлы

  • test1.zip (53.5 КБ)
 

msdmo

Пользователь

Сообщений: 4
Регистрация: 29.02.2016

#13

19.05.2017 16:17:45

Сделал.

Код 
FindText = Cells(9, i): ReplaceText = Trim$(.Cells(i)) 'менять номер строки с фигурными скобками

Ещё ошибки возникают, если объединённая ячейка попадается ((
Источник

Содержание

  • 1 Add a word document
  • 2 Close a document
  • 3 Generating Word ata from an Excel VBA program
  • 4 Load contact table from Access and create letter in Word
  • 5 Open an Existing Document
  • 6 Save a document
  • 7 Save Changes to a Document
  • 8 To close a specific document, you can close the active document or you can specify a document name:
  • 9 To create a new document that uses a specific template, use this:
  • 10 To save a document with a new name, use the SaveAs method

Add a word document

   <source lang="vb">

Sub wordDoc() 

   Dim WordApp As Object
   Set WordApp = CreateObject("Word.Application")
   With WordApp
       .Documents.Add
   End With

End Sub 

</source>

Close a document

   <source lang="vb">

Sub exitFor() 

   Dim Doc As Document
   For Each Doc In Documents
       If Doc.Name = "Document1" Then Exit For
       Doc.Close
   Next Doc

End Sub 

</source>

Generating Word ata from an Excel VBA program

   <source lang="vb">

Sub MakeMemos() 

   Dim WordApp As Object
   Set WordApp = CreateObject("Word.Application")
   
   For i = 1 To 3
       Application.StatusBar = "Processing Record " & i
       SaveAsName = ThisWorkbook.Path & "test.doc"
       With WordApp
           .Documents.Add
           With .Selection
               .Font.Size = 14
               .Font.Bold = True
               .ParagraphFormat.Alignment = 1
               .TypeText Text:="M E M O R A N D U M"
               .TypeParagraph
               .TypeParagraph
               .Font.Size = 12
               .ParagraphFormat.Alignment = 0
               .Font.Bold = False
               .TypeText Text:="Date:" & vbTab & Format(Date, "mmmm d, yyyy")
               .TypeParagraph
               .TypeText Text:="To:" & vbTab & " Manager"
               .TypeParagraph
               .TypeText Text:="From:" & vbTab & _
                  Application.userName
               .TypeParagraph
               .TypeParagraph
               .TypeText "text"
               .TypeParagraph
               .TypeParagraph
               .TypeText Text:="Units Sold:" & vbTab & "asdf"
               .TypeParagraph
               .TypeText Text:="Amount:" & vbTab & Format(1000, "$#,##0")
           End With
               .ActiveDocument.SaveAs FileName:=SaveAsName
               .ActiveWindow.Close
       End With
   Next i
   WordApp.Quit
   Set WordApp = Nothing
   Application.StatusBar = ""
   MsgBox " memos were created and saved in " & ThisWorkbook.Path

End Sub 

</source>

Load contact table from Access and create letter in Word

   <source lang="vb">

Sub ControlWord() 

   Dim objWord As New Word.Application
   Dim rsContacts As New ADODB.Recordset
   Dim strLtrContent As String
   rsContacts.ActiveConnection = CurrentProject.Connection
   rsContacts.Open "tblContacts"
   
   objWord.Documents.Add
   
   Do While Not rsContacts.EOF
     strLtrContent = rsContacts("FirstName") & " " & rsContacts("LastName")
     strLtrContent = strLtrContent & rsContacts("Address") & vbCrLf
     strLtrContent = strLtrContent & rsContacts("City") & ", " & rsContacts("Region")
     strLtrContent = strLtrContent & "  " & rsContacts("PostalCode") 
     strLtrContent = strLtrContent & "Dear " & rsContacts("FirstName") & " "
     strLtrContent = strLtrContent & rsContacts("LastName") & ":" 
   
       objWord.Selection.EndOf
       objWord.Selection.Text = strLtrContent
   
       objWord.Selection.EndOf
       objWord.Selection.InsertBreak
       
       rsContacts.MoveNext
   Loop
   objWord.Visible = True
   objWord.PrintPreview = True

End Sub 

</source>

Open an Existing Document

   <source lang="vb">

Sub Main() 

   Dim wdApp As Word.Application
   
   Set wdApp = GetObject(, "Word.Application")
   wdApp.Documents.Open Filename:="C:Arrays.docx", ReadOnly:=True, AddtoRecentFiles:=False

End Sub 

</source>

Save a document

   <source lang="vb">

Sub WordLateBound() 

   Dim objWord As Object 
   Dim objDoc As Object 
   Set objWord = CreateObject("Word.Application") 
   Set objDoc = objWord.Documents.Add 
   objDoc.SaveAs "C:testdoc2.doc" 
   objDoc.Close 
   Set objDoc = Nothing 
   Set objWord = Nothing

End Sub 

</source>

Save Changes to a Document

   <source lang="vb">

Sub main() 

   Dim wdApp As Word.Application
   
   Set wdApp = GetObject(, "Word.Application")
   wdApp.Documents.Save

End Sub 

</source>

To close a specific document, you can close the active document or you can specify a document name:

   <source lang="vb">

Sub main() 

   Dim wdApp As Word.Application
   Set wdApp = GetObject(, "Word.Application")
   wdApp.ActiveDocument.Close
   "or
   wdApp.Documents("Arrays.docx").Close

End Sub 

</source>

To create a new document that uses a specific template, use this:

   <source lang="vb">

Sub add() 

   Dim wdApp As Word.Application
   
   Set wdApp = GetObject(, "Word.Application")
   wdApp.Documents.Add Template:="Contemporary Memo.dot"

End Sub 

</source>

To save a document with a new name, use the SaveAs method

   <source lang="vb">

Sub Main() 

   Dim wdApp As Word.Application
   Set wdApp = GetObject(, "Word.Application")
   wdApp.ActiveDocument.SaveAs "C:MemoTest.docx"

End Sub 

</source>
Источник

  • Документы Word
  • Создание файлов
  • Работа с файлами

Таблица Excel с исходными данными для создания документов Word

Макрос предназначен для программного создания документов Word на основе шаблона

(без использования функции слияния в Word)

В прикреплённом к статье архиве находятся 2 файла:

  • шаблон договора в формате Microsoft Word (расширение .dot)
  • файл Excel с макросом

Настройки макроса задаются в коде:

Const ИмяФайлаШаблона = «шаблон.dot»
Const КоличествоОбрабатываемыхСтолбцов = 8
Const РасширениеСоздаваемыхФайлов = «.doc»

При нажатии кнопки запуска макрос на основе шаблона dot создаёт очередной файл, и в этом документе производит замену текста («кода поля») из первой строки файла Excel на значение поля (из очередной строки с данными файла Excel)

Папка для сформированных документов создаётся автоматически, и содержит в имени текущую дату и время
(например, созданная папка будет называться Договоры, сформированные 01-05-2011 в 15-03-24)

Имена создаваемых файлов формируются объединением полей фамилия, имя и отчество, с добавлением расширения doc

PS: Макрос был написан достаточно давно, когда я только начинал изучать VBA, — так что код недостаточно универсален.

Но, в качестве примера, пожалуй, подойдёт (если вам нужен более функциональный макрос, воспользуйтесь универсальной надстройкой (см. ниже))

Ознакомьтесь также с универсальной надстройкой формирования документов по шаблонам,
которая может делать всё тоже самое, что и эта программа,
только в качестве шаблонов могут выступать, помимо документов Word, ещё текстовые файлы, и книги Excel.

В надстройке — много возможностей, и полезных дополнений: склонение ФИО в родительный и дательный падежи, автоматический вывод на печать (с заданным количеством копий), размещение созданных файлов в разных папках, создание и рассылка писем со вложениями, и множество других полезных функций.

По вышеприведённой ссылке программа заполнения документов Word из Excel доступна для бесплатного скачивания.

Внимание: просьбы о доработке макроса, описанного в этой статье, не принимаются.

Есть новая (универсальная) версия, — в которой уже есть практически всё, что может понадобиться.

  • 197043 просмотра

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Источник

Like this post? Please share to your friends:
  • Vba excel создание ссылки
  • Vba excel создание списков
  • Vba excel создание списка
  • Vba excel создание пользовательской формы
  • Vba excel создание папок