将Excel数据对应写入已做好的Word模板的指定位置(分发)

素偶素偶 · 发表于 2024-8-7 16:47

求助：通过excel工作表2的内容，每行单独生成一个word表格，下面黄色的内容需要根据excel表格内容自动填充至word。
目前论坛找到了对应的vba（打开excel点击表1按钮即可生成），但是数据不会自动写入对应的格子。特此请教，谢谢！
【1】以下问excel表2内容，一行生成一个word。

【2】下图为结果图，示例。

饮冰e士 · 发表于 2024-8-7 17:24

这种的，邮件合并就可以了，不必VBA吧

素偶素偶 · 发表于 2024-8-7 18:18

饮冰e士发表于 2024-8-7 17:24
这种的，邮件合并就可以了，不必VBA吧

我这个wps 可以实现跟微软office 一样的功能吗？

饮冰e士 · 发表于 2024-8-7 18:30

.ActiveDocument.Tables(1).Cell(2, 2).Range = Sheets("êy¾Y").Cells(i, "B")
.ActiveDocument.Tables(1).Cell(2, 4).Range = Mid(Sheets("êy¾Y").Cells(i, "D"), 7, 8)
.ActiveDocument.Tables(1).Cell(3, 2).Range = Sheets("êy¾Y").Cells(i, "I")
.ActiveDocument.Tables(1).Cell(3, 4).Range = Sheets("êy¾Y").Cells(i, "C")
.ActiveDocument.Tables(1).Cell(4, 2).Range = Sheets("êy¾Y").Cells(i, "D")
.ActiveDocument.Tables(1).Cell(5, 4).Range = Sheets("êy¾Y").Cells(i, "G")

复制代码

gwjkkkkk · 发表于 2024-8-7 19:13

Option Explicit
Sub test()
Dim ar, br, i&, j&, wdApp As Object, strFileName$, strPath$, strSaveName$

strPath = ThisWorkbook.Path & "\"
strFileName = strPath & "培训报名表(模板).doc"
If Dir(strFileName) = "" Then MsgBox "模板文件不存在，请检查！", vbExclamation: Exit Sub

Application.ScreenUpdating = False

ar = Worksheets("数据").[A1].CurrentRegion.Value
br = [{4,2;10,3;12,4;17,7;8,9}]

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err <> 0 Then
      Set wdApp = CreateObject("Word.Application")
End If

For i = 2 To UBound(ar)
      With wdApp.documents.Open(strFileName)
         strSaveName = strPath & ar(i, 2)
         With .tables(1)
            For j = 1 To UBound(br)
                  .Range.Cells(br(j, 1)).Range.Text = ar(i, br(j, 2))
            Next j
            .Range.Cells(6).Range.Text = Mid(ar(i, 4), 7, 8)
         End With

         .SaveAs strSaveName: .Close
      End With
Next i

If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing

Application.ScreenUpdating = True
Beep
End Sub

gwjkkkkk · 发表于 2024-8-7 19:15

你这个邮件合并也比较简单，VBA也比较简单。。。

h2016 · 发表于 2024-8-8 08:41

邮件合并在功能差不多

3190496160 · 发表于 2024-8-8 10:34

Sub 批量word()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application") '新建Word对象
Dim d As Object
Dim wdd
t = Timer
Set d = CreateObject("scripting.dictionary")
Dim ar As Variant
Dim br()
lj = ThisWorkbook.Path
mb = lj & "\培训报名表(模板).doc"
If Dir(mb) = "" Then MsgBox "找不到模板文件！": Exit Sub
ar = ActiveSheet.[a1].CurrentRegion
wdApp.Visible = True
For i = 2 To UBound(ar)
If Len(Trim(ar(i, 2))) > 0 Then
      F = Dir(lj & "\" & ar(i, 2) & ".jpg")
      wj = ar(i, 2)
      FileCopy mb, lj & "\" & wj & ".doc"
      Set wdd = wdApp.Documents.Open(lj & "\" & wj & ".doc")
      For j = 2 To 10
         With wdApp.Selection
            .HomeKey unit:=6 '光标置于文件首
            If .Find.Execute("sj" & j - 1) Then '查找到指定字符串
                  .Font.Color = wdColorAutomatic '字符为自动颜色
                  .Text = ar(i, j) '替换字符串
            End If
         End With
      Next j
      If F <> "" Then
         tt = lj & "\" & F
         wdd.Tables(1).Cell(1, 2).Range.InlineShapes.AddPicture Filename:=tt, LinkToFile:=False, SaveWithDocument:=True '直接插入
         wdd.InlineShapes(1).Height = 135 '调整图片高度
         wdd.InlineShapes(1).Width = 100 '调整图片高度
      End If
      wdd.Save
      wdd.Close True
End If
Next i
wdApp.Quit
Set wdd = Nothing
Set wdApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "耗时：" & Format(Timer - t, "0.00") & "秒"
End Sub

3190496160 · 发表于 2024-8-8 10:35

生成word文档，同时，自动根据姓名插入照片

将Excel数据对应写入已做好的Word模板的指定位置(分发).rar (57.17 KB, 下载次数: 13)

3190496160 · 发表于 2024-8-8 10:36

将Excel数据对应写入已做好的Word模板的指定位置(分发).rar (57.17 KB, 下载次数: 23)

		自动登录	找回密码
密码			免费注册

[求助] 将Excel数据对应写入已做好的Word模板的指定位置(分发)

评分

评分