批量生成劳动合同

rbzy

看到说书签可以弄，但是没看到怎么弄

3190496160

Sub 批量word()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")   '新建Word对象
Dim sj001, sj002, sj003
Dim d As Object
Dim wdd
t = Timer
Dim ar As Variant
Dim br()
lj = ThisWorkbook.Path
mb = lj & "\全日制用工劳动合同示范文本.doc"
ar = ActiveSheet.[a1].CurrentRegion
wdApp.Visible = False
For i = 2 To UBound(ar)
    If Len(Trim(ar(i, 1))) > 0 Then
        wj = ar(i, 1)
        ar(i, 10) = ar(i, 1)
        FileCopy mb, lj & "\劳动合同\" & wj & ".doc"
        Set wdd = wdApp.Documents.Open(lj & "\劳动合同\" & wj & ".doc")
        For j = 1 To 10
            With wdApp.Selection
                .HomeKey unit:=6 '光标置于文件首
                If .Find.Execute("数据" & j) Then '查找到指定字符串
                    .Font.Color = wdColorAutomatic '字符为自动颜色
                    .Text = ar(i, j) '替换字符串
                End If
            End With
        Next j
        With wdApp.Selection
            .HomeKey unit:=6 '光标置于文件首
            If .Find.Execute("xm") Then '查找到指定字符串
                .Font.Color = wdColorAutomatic '字符为自动颜色
                .Text = ar(i, 1) '替换字符串
            End If
        End With
        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

劳动合同.rar (79.66 KB, 下载次数: 28)

2023-5-5 13:36 上传

点击文件名下载附件

3190496160

附件太不认真，需求说明几乎没有，所以，代码仅供参考

my0745

3190496160 发表于 2023-5-5 13:35
Sub 批量word()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

VBA用得好厉害啊

rbzy

3190496160 发表于 2023-5-5 13:37
附件太不认真，需求说明几乎没有，所以，代码仅供参考

谢谢，大概就是这样，然后怎么稍改文字的左右位置？是书签定位吗

Lovertdos

这样的合同据说没法律效力

梧叶沙沙

用Excel魔方插件可以轻松搞定，你这个需求很典型。

3190496160

rbzy 发表于 2023-5-5 17:33
谢谢，大概就是这样，然后怎么稍改文字的左右位置？是书签定位吗

左右位置？？？什么意思？？

rbzy

Lovertdos 发表于 2023-5-6 01:09
这样的合同据说没法律效力

当地人力资源部给的