Create a word docx from data in excel - one doc per row

Question

I want to create bunch of word docx from one excel sheet . One docx per each row.

I did it with this code

Option Explicit

'change this to where your files are stored

Const FilePath As String = "C:\Users\"
Sub WordDoc()
    Dim doc As Object
    Dim TextEnter As String
    Dim RowNum As Integer
    Dim wordApp As Object
    Dim lLastRow As Long, lRowLoop As Long, lLastCol As Long, lColLoop As Long

              
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    lLastCol = Cells(1, Columns.Count).End(xlToLeft).Column

    'For... Next Loop through all rows
    For lRowLoop = 2 To lLastRow
            
        Set wordApp = CreateObject("Word.Application") 'Takes the object wordApp and assigns it as a Microsoft Word application
        wordApp.Visible = True 'Word application is visible

    'Adds a new document to the application
        Set doc = wordApp.Documents.Add
        'save and this document
        doc.SaveAs2 (FilePath & Cells(lRowLoop, 1) & ".docx")
        

        TextEnter = ""
        'For... Next Loop to combine all columns (header and answer) for given row into string
        For lColLoop = 1 To lLastCol
            TextEnter = TextEnter & Cells(lRowLoop, lColLoop) & Chr(10) & Chr(10)
        Next lColLoop
        wordApp.Selection.TypeParagraph 'Moves to the next line in word doc
        wordApp.Selection.TypeText Text:=TextEnter 'Enters Text to document
        
    
    
    Set doc = Nothing
    Set wordApp = Nothing

    Next lRowLoop
    
    MsgBox "Done"
    
End Sub

But the proble is that it opens all of the created docx and mz real data has thousends of rows, how to change the code so that it wont open the docx files (only saves them)? And second how to add encoding UTF-8 for created docx?

Answer 1

You need to save the document after editing and then close it.

Sub WordDoc()

    Dim wordApp As Object, doc As Object
    Dim TextEnter As String, RowNum As Integer
    Dim lLastRow As Long, lRowLoop As Long, lLastCol As Long, lColLoop As Long
    Dim filename As String

    Dim wb As Workbook, ws As Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
       
    lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

    ' start Word
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True

    ' scan down sheet
    For lRowLoop = 2 To lLastRow
            
        'Adds a new document
        Set doc = wordApp.Documents.Add

        'For... Next Loop to combine all columns (header and answer)
        'for given row into string
        TextEnter = ""
        For lColLoop = 1 To lLastCol
            TextEnter = TextEnter & ws.Cells(lRowLoop, lColLoop) & Chr(10) & Chr(10)
        Next lColLoop
        
        doc.Sentences(1) = TextEnter
        
        'save and close doc
        filename = Cells(lRowLoop, 1) & ".docx"
        doc.SaveAs2 FilePath & filename, Encoding:=65001 'msoEncodingUTF8
        doc.Close False
    
        Set doc = Nothing

    Next lRowLoop
    
    wordApp.Quit
    Set wordApp = Nothing
    MsgBox lRowLoop - 2 & " Documents created", vbInformation
    
End Sub