VBA可以将excel单元格内容,替换word文档指定位置中的内容么?
2个回答
展开全部
当然可以,我以前写的,你可以参考一下:
Private Sub CommandButton1_Click()
On Error Resume Next
Dim iRow As Integer, myPath As String
Dim wdApp As Word.Application, wdDoc As Word.Document, wdRange As Word.Range
Dim 收文日期 As String, 标题 As String, 来文单位 As String, 文号 As String, 拟办情况 As String
'--------------------------------------------------------------------------------------------------------
Label3.Caption = "封面正在生成中..."
'--------------------------------------------------------------------------------------------------------
iRow = TextBox1.Text
'获取待填写信息
来文单位 = Cells(iRow, 3).Text
来文单位 = Replace(来文单位, Chr(10), "^p") '将excel中的换行替换成word中的换行
文号 = Cells(iRow, 4).Text
文号 = Replace(文号, Chr(10), "^p") '将excel中的换行替换成word中的换行
标题 = Cells(iRow, 5).Text
标题 = Replace(标题, Chr(10), "^p") '将excel中的换行替换成word中的换行
收文日期 = CStr(Year(Now())) & Cells(iRow, 6).Text
拟办情况 = TextBox2.Text
'--------------------------------------------------------------------------------------------------------
myPath = ThisWorkbook.Path & "\封面\"
'文件若已打开,则关闭已打开文件
For Each wdDoc In Documents
If InStr(1, wdDoc.Name, myPath & "(" & 收文日期 & ")" & 标题 & ".doc", 1) Then
wdDoc.Close savechanges:=wdDoNotSaveChanges
Exit For
End If
Next wdDoc
'--------------------------------------------------------------------------------------------------------
Set wdDoc = CreateObject(myPath & "空白模板.doc") '打开word
wdDoc.Activate
'--------------------------------------------------------------------------------------------------------
'填写文档
Set wdRange = wdDoc.Content '将word的文档内容赋予wdrange
wdRange.Find.Execute FindText:="{来文单位}", ReplaceWith:=来文单位, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{文号}", ReplaceWith:=文号, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{收文时间}", ReplaceWith:=收文日期, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{内容摘要}", ReplaceWith:=标题, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{办公室拟办}", ReplaceWith:=拟办情况, Replace:=wdReplaceAll
'--------------------------------------------------------------------------------------------------------
'文档另存为
wdDoc.SaveAs Filename:=myPath & "(" & 收文日期 & ")" & 标题 & ".doc"
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Dim iRow As Integer, myPath As String
Dim wdApp As Word.Application, wdDoc As Word.Document, wdRange As Word.Range
Dim 收文日期 As String, 标题 As String, 来文单位 As String, 文号 As String, 拟办情况 As String
'--------------------------------------------------------------------------------------------------------
Label3.Caption = "封面正在生成中..."
'--------------------------------------------------------------------------------------------------------
iRow = TextBox1.Text
'获取待填写信息
来文单位 = Cells(iRow, 3).Text
来文单位 = Replace(来文单位, Chr(10), "^p") '将excel中的换行替换成word中的换行
文号 = Cells(iRow, 4).Text
文号 = Replace(文号, Chr(10), "^p") '将excel中的换行替换成word中的换行
标题 = Cells(iRow, 5).Text
标题 = Replace(标题, Chr(10), "^p") '将excel中的换行替换成word中的换行
收文日期 = CStr(Year(Now())) & Cells(iRow, 6).Text
拟办情况 = TextBox2.Text
'--------------------------------------------------------------------------------------------------------
myPath = ThisWorkbook.Path & "\封面\"
'文件若已打开,则关闭已打开文件
For Each wdDoc In Documents
If InStr(1, wdDoc.Name, myPath & "(" & 收文日期 & ")" & 标题 & ".doc", 1) Then
wdDoc.Close savechanges:=wdDoNotSaveChanges
Exit For
End If
Next wdDoc
'--------------------------------------------------------------------------------------------------------
Set wdDoc = CreateObject(myPath & "空白模板.doc") '打开word
wdDoc.Activate
'--------------------------------------------------------------------------------------------------------
'填写文档
Set wdRange = wdDoc.Content '将word的文档内容赋予wdrange
wdRange.Find.Execute FindText:="{来文单位}", ReplaceWith:=来文单位, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{文号}", ReplaceWith:=文号, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{收文时间}", ReplaceWith:=收文日期, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{内容摘要}", ReplaceWith:=标题, Replace:=wdReplaceAll
wdRange.Find.Execute FindText:="{办公室拟办}", ReplaceWith:=拟办情况, Replace:=wdReplaceAll
'--------------------------------------------------------------------------------------------------------
'文档另存为
wdDoc.SaveAs Filename:=myPath & "(" & 收文日期 & ")" & 标题 & ".doc"
End Sub
追问
偶像,方便留个QQ加个好友么?
我的qq:16846993,您加我也行!
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询