|
Sub 生成word文档()
Application.ScreenUpdating = False
Dim ar As Variant
Dim wdWORD, wdD
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空!": End
ar = .Range("a1:ab" & r)
End With
Set wdWORD = CreateObject("Word.Application") '定义- -个Word对象变量
wdWORD.Visible = True
lj = ThisWorkbook.Path & "\"
wj = lj & "模板.docx"
Set wdD = wdWORD.Documents.Open(wj)
With wdWORD.Selection
For i = 5 To UBound(ar)
zf = "": zd = ""
If ar(i, 2) <> "" Then
zd = ar(i, 1) & "、" & ar(i, 2) & "同志基本情况" & Chr(10) & " " & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 5) & ar(i, 6) & ar(i, 7) & ar(i, 8) & "人," & Format(ar(i, 9), "yyyy年mm月dd日") & "出生," & Format(ar(i, 10), "yyyy年mm月dd日") & "参加工作,现为" & ar(i, 11) & ar(i, 12) & "教师。"
For j = 13 To 16
If ar(i, j) <> "" Then
If zf = "" Then
zf = " 曾经在" & ar(i, j)
Else
zf = zf & "," & " 曾经在" & ar(i, j)
End If
End If
Next j
zf = zf & "任教,"
For j = 17 To UBound(ar, 2) - 2 Step 3
If ar(i, j) <> "" Then
zf = zf & Format(ar(i, j), "yyyy年mm月dd日") & "获得" & ar(i, j + 1) & ar(i, j + 2) & "称号,"
End If
Next j
zd = zd & Chr(10) & Left(zf, Len(zf) - 1) & "。"
If i = 5 Then
.HomeKey unit:=6 '光标置于文件首
.TypeText Text:=zd
Else
.TypeParagraph '''光标下移一行
.endkey unit:=6 '''光标定位文件末尾
.TypeText Text:=zd
End If
End If
Next i
End With
wdWORD.ActiveDocument.SaveAs Filename:=lj & "教师信息" & Format(Date, "yyyymmdd") & ".docx"
wdWORD.Quit ''关闭新建文档窗口
Set wdWORD = Nothing ''释放存储空间
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|