有没有一种方法可以根据列中的条件将表格数据从 Excel 导出到 Word 文档模板？

Question

我有 Excel 文件的要求。现在我们要构建一个需求选择器。其中销售人员只需单击所有需求组（复选标记）并将它们添加到预先指定的 Word 文档中即可。目标是拥有单一的真实需求来源，并且使销售人员能够从头开始创建需求文档，同时还可以根据客户的具体愿望进行定制。

我尝试使用VBA，代码在下面。它创建一个 Word 文档。但它只输出最后一行数据，而不输出我用“JA”（=“是”）突出显示的任何其他数据。

这是数据：

要求	标题组	选择群组	包括（JA/NEE）
要求1	第 1 组	第 1 组	JA
要求2	第2组	第2组	JA
锌 1 锌 3 锌 5	第3组	第3组	JA

数据截图

这是我用VBA添加的按钮：

Sub GenerateWordDoc()
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim i As Integer
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim currentGroup As String
    Dim j As Integer
    Dim reqText As String
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Update to your sheet name if necessary
    
    ' Create Word Application and Document
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Add
    
    ' Get the last row of the data
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through the "Include (JA/NEE)" column (D) to find groups marked as "JA"
    For i = 2 To lastRow
        ' If "JA" is selected in the "Include (JA/NEE)" column
        If ws.Cells(i, 4).Value = "JA" Then
            currentGroup = ws.Cells(i, 3).Value ' Get the group name from the "Select Group" column (C)
            
            ' Add the group name as a heading in the Word document
            WordDoc.Paragraphs.Add.Range.Text = "Group: " & currentGroup
            
            ' Initialize the text variable for the requirements
            reqText = ""
            
            ' Loop through all rows to add the requirements that belong to the current group
            For j = 2 To lastRow
                ' If the "Heading Group" (Column B) matches the current group
                If ws.Cells(j, 2).Value = currentGroup Then
                    ' Append the requirement to the reqText string
                    reqText = reqText & vbCrLf & ws.Cells(j, 1).Value ' Add requirement text
                End If
            Next j
            
            ' Write the accumulated requirements for the group to the Word document
            WordDoc.Paragraphs.Add.Range.Text = reqText
        End If
    Next i
    
    ' Save and display the document
    WordDoc.SaveAs2 "GeneratedRequirements.docx"
    WordApp.Visible = True
End Sub

Answer 1

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sTxt As String, vKey
    Dim oSht As Worksheet, arrData
    Set oSht = Sheets("Sheet1")
    Set objDic = CreateObject("scripting.dictionary")
    Set rngData = oSht.Range("A1").CurrentRegion
    arrData = rngData.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        If arrData(i, 4) = "JA" Then
            sTxt = arrData(i, 3)
            If Not objDic.exists(sTxt) Then
                objDic(sTxt) = ""
            End If
        End If
    Next
    For i = LBound(arrData) + 1 To UBound(arrData)
        sTxt = arrData(i, 2)
        If objDic.exists(sTxt) Then
            objDic(sTxt) = objDic(sTxt) & vbCr & arrData(i, 1)
        End If
    Next i
    sTxt = ""
    For Each vKey In objDic.Keys
        sTxt = sTxt & vbCr & "Group: " & vKey & objDic(vKey)
    Next
    Debug.Print sTxt
    Dim WordApp As Object, WordDoc As Object
    ' Create Word Application and Document
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True
    Set WordDoc = WordApp.Documents.Add
    WordDoc.Range.Text = Mid(sTxt, 2)
    ' Save and display the document
    WordDoc.SaveAs2 ThisWorkbook.Path & "\GeneratedRequirements.docx"
    WordApp.Visible = True
    ' WordApp.Quit
End Sub