从excel中的数据创建一个word docx - 每行一个文档

如何解决从excel中的数据创建一个word docx - 每行一个文档

我想从 one excel sheet 创建一堆单词 docx。每行一个 docx。

我用这段代码做到了

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

但问题是它打开了所有创建的 docx 并且 mz 真实数据有成千上万的行，如何更改代码使其不会打开 docx 文件（只保存它们）？ 其次，如何为创建的 docx 添加编码 UTF-8？

解决方法

您需要save编辑文档然后close它。

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