将excel数据输出到word文档

Question

我有一个需要输出到 word 文档的 excel 文件，问题是我需要与工作表中的行一样多的 word 文档。

excel文件如下所示：

<style type="text/css">
  .tg {
    border-collapse: collapse;
    border-spacing: 0;
  }
  .tg td {
    font-family: Arial, sans-serif;
    font-size: 14px;
    padding: 10px 5px;
    border-style: solid;
    border-width: 1px;
    overflow: hidden;
    word-break: normal;
  }
  .tg th {
    font-family: Arial, sans-serif;
    font-size: 14px;
    font-weight: normal;
    padding: 10px 5px;
    border-style: solid;
    border-width: 1px;
    overflow: hidden;
    word-break: normal;
  }
  .tg .tg-yw4l {
    vertical-align: top
  }
</style>
<table class="tg">
  <tr>
    <th class="tg-yw4l">Unit</th>
    <th class="tg-yw4l">subject</th>
    <th class="tg-yw4l">Answer1</th>
    <th class="tg-yw4l">Answer2</th>
    <th class="tg-yw4l">observation</th>
  </tr>
  <tr>
    <td class="tg-yw4l">xx/xx</td>
    <td class="tg-yw4l">change demand</td>
    <td class="tg-yw4l">ok</td>
    <td class="tg-yw4l">handling1</td>
    <td class="tg-yw4l">will be done on...</td>
  </tr>
  <tr>
    <td class="tg-yw4l">xx/xx</td>
    <td class="tg-yw4l">phone demand</td>
    <td class="tg-yw4l">nok</td>
    <td class="tg-yw4l">handlingnok</td>
    <td class="tg-yw4l">out of phones</td>
  </tr>
  <tr>
    <td class="tg-yw4l">yyy/yyy</td>
    <td class="tg-yw4l">computer demand</td>
    <td class="tg-yw4l">ok</td>
    <td class="tg-yw4l">handling3</td>
    <td class="tg-yw4l">queued for delivery</td>
  </tr>
</table>

实际代码取一个word模板文档，并用值填充它，事情是：

1. 它输出的行数不如文档中的行数（可能 UNIT 变量存在冲突，这就是我添加“a”变量以唯一命名文件的原因）

单独创建每个文档而不是使用模板会更好吗？有没有办法用模板做到这一点？

这是 VBA 代码：

Sub reply()

Dim wdApp As Object
Dim iRow As Long
Dim ReferenceDoc As String
Dim DocSubject As String
Dim unit As String
Dim Answer1 As String
Dim NmrTicket As String
Dim RepType As String
Dim wDoc As Word.Document
Dim Answer2 As String
Dim Observation As String
Dim Answer2Val As String
Dim j As Integer
Dim rep1 As String
Dim val1 As String
Dim unit2 As String
Dim Fname As String
Dim unitLast As String
Dim a As Integer
Dim Datecomision As Date







   iRow = 5
    a = 1
    Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = True
     Set wDoc = wdApp.Documents.Open("K:\ModlNE2.dotx", ReadOnly:=True)

         playAlerts = False




    Sheets("comision").Select
        Do Until IsEmpty(Cells(iRow, 1))
            Sheets("comision").Select

    ReferenceDoc = Cells(iRow, 1).Value
    'ReferenceDoc = DateFeb
    unitLast = Cells(iRow - 1, 2).Value
    unit = Cells(iRow, 2).Value
    DocSubject = Cells(iRow, 3).Value
    Answer1 = Cells(iRow, 7).Value
    Observation = Cells(iRow, 8).Value
    Answer2 = Cells(iRow, 9).Value
    Datecomision = "03/11/2016"

    unit2 = Replace(unit, "/", "")
    unit2 = Replace(unit2, " ", "")


            ''compare value of answer2 to give the variable a longer text answer for the document
                    j = 2
                        Sheets("Answer2s").Select
                        Do Until IsEmpty(Cells(j, 1))
                            rep1 = Cells(j, 1).Value
                            val1 = Cells(j, 2).Value
                                If Answer2 = rep1 Then
                                    Answer2Val = val1
                                End If

                        j = j + 1
                    Loop


                j = 1




    With wDoc
        Set wDoc = wdApp.Documents.Open("K:\ModlNE2.dotx", ReadOnly:=True)

         playAlerts = False

         .Application.Selection.Find.Text = "<<unit>>"
         .Application.Selection.Find.Execute
         .Application.Selection = unit
         .Application.Selection.EndOf

         .Application.Selection.Find.Text = "<<Datecomision>>"
         .Application.Selection.Find.Execute
         .Application.Selection = Datecomision
         .Application.Selection.EndOf

        .Application.Selection.Find.Text = "<<ReferenceDoc>>"
         .Application.Selection.Find.Execute
         .Application.Selection = ReferenceDoc
         .Application.Selection.EndOf

         .Application.Selection.Find.Text = "<<DocSubject>>"
         .Application.Selection.Find.Execute
         .Application.Selection = DocSubject
         .Application.Selection.EndOf


         .Application.Selection.Find.Text = "<<Answer1>>"
         .Application.Selection.Find.Execute
         .Application.Selection = Answer1
         .Application.Selection.EndOf

         .Application.Selection.Find.Text = "<<Answer2>>."
         .Application.Selection.Find.Execute
         .Application.Selection = Answer2Val
         .Application.Selection.EndOf



         Fname = Format(Date, "dd/mm/yyyy") & ("_ANSWER_CHANGE_COMMISSION_") & unit2 & iRow & a & ".doc"
         Fname = Replace(Fname, "/", "")
         .SaveAs Filename:="K:\test\" & Fname
              .Close


      End With


      iRow = iRow + 1
        a = a + 1
   Loop


   Set olApp = Nothing
   Exit Sub





End Sub

Answer 1

您的代码只是被selection 的使用弄糊涂了，而是使用对象。我添加了两个对象变量来保存工作表。

试试这个：

Sub output_excel_data_to_word_documents_ANSWER()
Dim wsh1 As Worksheet
Dim wsh2 As Worksheet

Dim wdApp As Object
Dim iRow As Long
Dim ReferenceDoc As String
Dim DocSubject As String
Dim unit As String
Dim Answer1 As String
''Dim NmrTicket As String    'variable not used!
''Dim RepType As String      'variable not used!
Dim wDoc As Word.Document
Dim Answer2 As String
Dim Observation As String
Dim Answer2Val As String
Dim j As Integer
Dim rep1 As String
Dim val1 As String
Dim unit2 As String
Dim Fname As String
Dim unitLast As String
Dim a As Integer
Dim Datecomision As Date

    iRow = 5
    a = 1

    With ThisWorkbook
        Set wsh1 = .Worksheets("comision")
        Set wsh2 = .Worksheets("Answer2s")
    End With

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

    Do Until IsEmpty(wsh1.Cells(iRow, 1))
        With wsh1
            ReferenceDoc = .Cells(iRow, 1).Value
            'ReferenceDoc = DateFeb
            unitLast = .Cells(iRow - 1, 2).Value
            unit = .Cells(iRow, 2).Value
            DocSubject = .Cells(iRow, 3).Value
            Answer1 = .Cells(iRow, 7).Value
            Observation = .Cells(iRow, 8).Value
            Answer2 = .Cells(iRow, 9).Value
            Datecomision = "03/11/2016"
            unit2 = Replace(unit, "/", "")
            unit2 = Replace(unit2, " ", "")
        End With

        ''compare value of answer2 to give the variable a longer text answer for the document
        j = 2
        With wsh2
            Do Until IsEmpty(.Cells(j, 1))
                rep1 = .Cells(j, 1).Value
                val1 = .Cells(j, 2).Value
                If Answer2 = rep1 Then
                    Answer2Val = val1
                End If
                j = j + 1
        Loop: End With

        Set wDoc = wdApp.Documents.Open("K:\ModlNE2.dotx", ReadOnly:=True)
        With wdApp
            .Selection.Find.Text = "<<unit>>"
            .Selection.Find.Execute
            .Selection = unit
            .Selection.EndOf

            .Selection.Find.Text = "<<Datecomision>>"
            .Selection.Find.Execute
            .Selection = Datecomision
            .Selection.EndOf

            .Selection.Find.Text = "<<ReferenceDoc>>"
            .Selection.Find.Execute
            .Selection = ReferenceDoc
            .Selection.EndOf

            .Selection.Find.Text = "<<DocSubject>>"
            .Selection.Find.Execute
            .Selection = DocSubject
            .Selection.EndOf

            .Selection.Find.Text = "<<Answer1>>"
            .Selection.Find.Execute
            .Selection = Answer1
            .Selection.EndOf

            .Selection.Find.Text = "<<Answer2>>."
            .Selection.Find.Execute
            .Selection = Answer2Val
            .Selection.EndOf

            .Selection.TypeParagraph

        End With

        Fname = Format(Date, "ddmmyyyy") & ("_ANSWER_CHANGE_COMMISSION_") & unit2 & iRow & a & ".doc"
        wDoc.SaveAs Filename:="K:\test\" & Fname
        wDoc.Close

        iRow = iRow + 1
        a = a + 1
    Loop

    End Sub