Creating Word document from an excel table

vasilshterev

New Member
Joined
Apr 30, 2018
Messages
2
Hello guys,
I am trying to create word documents based on an excel table as follows:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Word doc 1[/TD]
[TD]Word doc 2[/TD]
[TD]Word doc 3[/TD]
[/TR]
[TR]
[TD]Line 1[/TD]
[TD]Yes[/TD]
[TD]Yes[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Line 2[/TD]
[TD]Yes[/TD]
[TD][/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]Line 3[/TD]
[TD]Yes[/TD]
[TD]Yes[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]Line 4[/TD]
[TD][/TD]
[TD]Yes[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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:
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
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
I figured it out - not the nicest looking solution but it works.
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.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
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top