Создание документов Word из таблицы Excel

Question

Я пытаюсь создать текстовые документы на основе таблицы Excel следующим образом:

В конце создается 3 документа, и каждому из них соответствуют только строки с Да. Моя проблема в том, что он не сохраняет форматирование строк. Может ли кто-нибудь помочь мне с этим? Вот код:

Sub NewWordDocument()

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim i As Integer
Dim j As Integer
Dim LineCount As Integer
Dim DocumentCount As Integer

LineCount = Application.CountA(Range("A:A")) ' To see how many lines should be inputed
DocumentCount = Application.CountA(Range("B2:AZ2")) 'To see how many documents should be created

For j = 1 To DocumentCount
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Add ' or 'Set wrdDoc =wrdApp.Documents.Open("C:\Foldername\Filename.doc") 'sample word operations

    wrdApp.Selection.TypeText Text:="Heading One"

    With wrdDoc    
    For i = 1 To LineCount
        If Cells(i + 2, j + 1).Value = "Yes" Then
            .Range.InsertAfter Cells(i + 2, 1) 'Different way to paste the text. It doesn't keep the formatting
            .Range.InsertParagraphAfter
        End If
    Next i

    If Dir("D:\" & Cells(2, j + 1).Value & ".docx") <> "" Then
    Kill "D:\" & Cells(2, j + 1).Value & ".docx"
    End If

    .SaveAs ("D:\" & Cells(2, j + 1).Value & ".docx")
    .Close ' close the document
    End With
    wrdApp.Quit ' close the Word application
    Set wrdDoc = Nothing
    Set wrdApp = Nothing

Next j
End Sub

Если я делаю это вручную, копирование ячейки и вставка ее в слово работает отлично - сохраняет формат и удаляет таблицу, но когда я использую «Selection.PasteExcelTable False, False, False» вместо «InsertAfter», я просто перезаписываю тот же текст вместо добавления в конец страницы.

Кроме того, как я могу отформатировать заголовок, чтобы он был жирным и центрированным?

Answer 1

Я понял это - вероятно, это не лучший способ сделать это, но это более или менее работает для меня.

Sub NewWordDocument()

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim i As Integer
Dim j As Integer
Dim LineCount As Integer
Dim DocumentCount As Integer

LineCount = Application.CountA(Range("A:A")) ' To see how many lines should be inputed
DocumentCount = Application.CountA(Range("B2:AZ2")) 'To see how many documents should be created

For j = 1 To DocumentCount
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add ' or 'Set wrdDoc = wrdApp.Documents.Open("C:\Foldername\Filename.doc") 'sample word operations

wrdApp.Selection.Font.Name = "Calibri"
wrdApp.Selection.Font.Size = 18
wrdApp.Selection.Font.Allcaps = True
wrdApp.Selection.Font.Bold = True
wrdApp.Selection.TypeText Text:="Title"

With wrdDoc
.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
    PageNumberAlignment:=wdAlignPageNumberRight, _
    FirstPage:=True

.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "Header text" 'Add text in the header
.Content.InsertParagraphAfter

For i = 1 To LineCount
    If Cells(i + 2, j + 1).Value = "Yes" Then
         Range("A" & i + 2).Copy
         wrdApp.Selection.GoTo What:=wdGoToBookmark, Name:="\Page"
         wrdApp.Selection.MoveRight Unit:=wdCharacter, Count:=1
         wrdApp.Selection.PasteSpecial
        .Content.InsertParagraphAfter
    End If
Next i

        wrdApp.Selection.Font.Name = "Calibri"
        wrdApp.Selection.Font.Size = 11
        wrdApp.Selection.Font.Allcaps = False
        wrdApp.Selection.Font.Bold = False
wrdApp.Selection.TypeText Text:="Ending Text"


If Dir("D:\" & Cells(2, j + 1).Value & ".docx") <> "" Then
Kill "D:\" & Cells(2, j + 1).Value & ".docx"
End If

.SaveAs ("D:\" & Cells(2, j + 1).Value & ".docx")
.Close ' close the document
End With
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing


Next j

End Sub