如何将excel中同一个人的多条数据转到word模板中？

peals

请问各位大侠：
excel中有所有需要上课老师的信息，同一个老师可能会有几条数据，要将同一个老师的所有数据转到word版的教学任务书内，请问我应该怎么做才能实现？

fxl447098457

vba可以实现。先mark一下。

fxl447098457

word vba.表格填充了部分，供参考。

1. Sub dataToWord()
   
2. Dim xlApp As Object, k As Long, Connect$, StrSQL$, myname$
   
3. Dim d As Object, Arr, i%, ds, Rst As Object, m%
   
4. Set d = VBA.CreateObject("scripting.dictionary")
   
5. Set Rst = VBA.CreateObject("adodb.recordset")
   
6. Set xlApp = VBA.CreateObject("Excel.Application")
   
7. With xlApp.Workbooks.Open(ActiveDocument.Path & "\excel数据.xlsx").sheets(1)
   
8.     Arr = .Range("A2:N" & .Cells(.Rows.Count, 1).End(3).Row)
   
9.     .Parent.Close 0
   
10. End With
    
11. Rst.cursorlocation = 3
    
12. Connect = "Provider=Microsoft.ACE.oledb.12.0;extended properties=excel 12.0;data source=" _
    
13. & ActiveDocument.Path & "\excel数据.xlsx"
    
14. For i = 1 To UBound(Arr)
    
15. d(Arr(i, 1)) = ""
    
16. Next
    
17. k = 2
    
18. Application.ScreenUpdating = False
    
19. For Each ds In d.KEYS
    
20.   StrSQL = "Select * from [Sheet1$A:N] Where 授课老师='" & ds & "'"
    
21.   Rst.Open StrSQL, Connect, 1, 3
    
22.   If Rst.RecordCount Then
    
23.      With ActiveDocument
    
24.         With .Content.Find
    
25.          m = m + 1
    
26.         .Execute findtext:=IIf(m = 1, "                 老师", myname & "老师"), Replacewith:=ds & "老师", Replace:=wdReplaceOne
    
27.         End With
    
28.         With .Tables(1)
    
29.             Do While Not Rst.EOF
    
30.                 k = k + 1
    
31.                 .Cell(k, 1).Range.Text = Rst.Fields(2).Value
    
32.                 .Cell(k, 2).Range.Text = Rst.Fields(1).Value
    
33.                 .Cell(k, 3).Range.Text = Rst.Fields(6).Value
    
34.                 .Cell(k, 4).Range.Text = Rst.Fields(7).Value
    
35.                 .Cell(k, 5).Range.Text = IIf(Rst.Fields(4).Value = Split(.Cell(1, 5).Range.Text, vbCr)(0), "Y", "")
    
36.                 .Cell(k, 6).Range.Text = IIf(Len(.Cell(1, 5).Range.Text) > 1, "", "Y")
    
37.             Rst.MoveNext
    
38.            Loop
    
39.         End With
    
40.             k = 2
    
41.         .SaveAs2 ActiveDocument.Path & "" & ds & ".docx", wdFormatXMLDocument
    
42. 
    
43.      End With
    
44.     End If
    
45.     Rst.Close
    
46.     myname = ds
    
47. Next ds
    
48. Application.ScreenUpdating = True
    
49. Set xlApp = Nothing
    
50. Set d = Nothing
    
51. Set Rst = Nothing
    
52. End Sub

复制代码

fxl447098457

见附件。。。。 数据.rar (59.57 KB, 下载次数: 91)

2017-11-30 07:12 上传

点击文件名下载附件

peals

非常感谢！我试试！

秋枫

我觉得，excel to word, 应该是邮件合并才对：）

200317084

fxl447098457 发表于 2017-11-30 07:12
见附件。。。。

我也正好需要这个，非常感谢