Creating Word documents from excel table - excel

Question

I am trying to create word documents based on an excel table as follows:
At the end this creates 3 documents and each one has only the lines with Yes corresponding to it. My problem is that it doesn't keep the formatting of the lines. Can somebody help me with this? Here is the code:
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
If I do it manually, copying the cell and pasting it in word works perfectly - keeps the format and removes the table but when I use 'Selection.PasteExcelTable False, False, False' instead of 'InsertAfter' , I simply overwrite the same text instead of adding to the end of the page.
Also, how can I format the "Heading one" to be bold and center?

Answer 1

I figured it out - it is probably not the best way to do it but it more or less works for me.
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