利用vba实现邮件合并中有个问题，求帮助！谢谢

seatky

前辈好，本人是个新手。因为工作需要，参考一些前辈的代码设计了一套vba。跟邮件合并是类似的，即在Excel中录入数据，通过vba宏，在固定模板的word里实现批量导出。
但是在vba代码运行过程中，只能实现第一数据行的数据代入替换。打个比方，模板是一页，数据行有3行，那么导出的批文件word是3页，应当是每一页调取Excel中每一行的数据资源，但是这3页的每一页调用的都是第一数据行的数据资源。

请求各位前辈的帮助。因为工作要求，word模板不太方便直接贴出来，暂且先粘贴一下vba代码。
以下是我的代码，万望有大神能够指点一下，非常感谢了！

   Dim Word对象 As New Word.Application, 当前路径, 导出文件名, 导出路径文件名, 判断, i, j
   Dim Str1, Str2
   当前路径 = ThisWorkbook.Path
   最后行号 = Sheets("数据").Range("B65536").End(xlUp).Row
   判断 = 0
   导出文件名 = "公司直接打印.doc"
   导出路径文件名 = 当前路径 & "\" & 导出文件名
   FileCopy 当前路径 & "\模板\公司.doc", 导出路径文件名
   With Word对象
      .Documents.Open 导出路径文件名
      .Visible = False
      .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
      .Selection.WholeStory '全选
      .Selection.Copy '复制
      If 最后行号 > 3 Then
         For i = 3 To 最后行号 - 1 '复制页
            .Selection.EndKey Unit:=wdStory '光标置于文件尾
            .Selection.InsertBreak Type:=wdPageBreak '分页
            .Selection.PasteAndFormat (wdPasteDefault) '粘贴
         Next i
      End If
      For i = 3 To 最后行号
        For j = 1 To 9 '填写文字数据
           Str1 = "数据" & Format(j, "000")
           Str2 = Sheets("数据").cells(i, j + 1)
           .Selection.HomeKey Unit:=wdStory '光标置于文件首
           Do While .Selection.Find.Execute(Str1)
                .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
                .Selection.Text = Str2 '替换字符串
                .Selection.HomeKey Unit:=wdStory
            Loop
        Next j
      Next i
   End With
   Word对象.Documents.Save
   Word对象.Quit
   Set Word对象 = Nothing
   If 判断 = 0 Then
      i = MsgBox("已生成“" & 导出路径文件名 & "”！", 0 + 48 + 256 + 0, "提示：")
   End If
End Sub

seatky

能帮帮忙么。。。

小花鹿

能写出这样的代码已经很厉害了，仔细调试一下应该能解决问题