Creating Word document from an excel table

[vasilshterev]

Hello guys,
I am trying to create word documents based on an excel table as follows:

	Word doc 1	Word doc 2	Word doc 3
Line 1	Yes	Yes
Line 2	Yes		Yes
Line 3	Yes	Yes	Yes
Line 4		Yes

<tbody>
</tbody>

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?

Thanks in advance,
Vasil

 

[vasilshterev]

I figured it out - not the nicest looking solution but it works.

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