作者：乔山办公网日期：
返回目录：excel表格制作
代码如下：抄
Sub 替换一次zhidao()
Dim Ra As Range
For Each Ra In Range("K8:K11")
If Ra = "a" Then
Ra = "b"
ElseIf Ra = "b" Then
Ra = "c"
ElseIf Ra = "c" Then
Ra = "aa"
End If
Next
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, 来文单e799bee5baa6e79fa5e98193e59b9ee7ad94334位 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
下面是代码是我应用中的一个过程，可以作为例子供你参考：
'★★★★自动生成e799bee5baa6e997aee7ad94e78988e69d83364提示书文件★★★★
Sub 生成提示书WORD文件()
'变量定义
Dim i, j, h, p, n, st
Set st = GetSheet("提示书用表")
If st Is Nothing Then Exit Sub
st.Activate
h = 9 '标题行
n = Trim(st.Cells(3, 2).Value)
If Not FileExist(n) Then
MsgBox "模板文件（" & n & "）不存在！"
Exit Sub
End If
p = InStrRev(n, "\")
If p = 0 Then p = "" Else p = Left(n, p)
Dim WordApp As Object
'开始启动WORD进程
Set WordApp = CreateObject("Word.Application")
i = h + 1
While st.Cells(i, 1) <> ""
WordApp.Documents.Add
WordApp.Selection.InsertFile Filename:=n
For j = 1 To st.UsedRange.Columns.Count
If st.Cells(h, j) <> "" Then
With WordApp.Selection.Find
.Text = "<<" & st.Cells(h, j) & ">>"
.Replacement.Text = st.Cells(i, j).Text
.Forward = True
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = 1 'wdFindContinue
.Execute Replace:=2 'wdReplaceAll
End With
End If
Next j
WordApp.ActiveDocument.SaveAs Filename:=p & st.Cells(i, 1).Text & ".doc", FileFormat:=0 'wdFormatDocument
WordApp.ActiveDocument.Close
i = i + 1
Wend
WordApp.Quit '退出
Set WordApp = Nothing '取消变量
MsgBox "全部文件生成完毕（" & p & "）！"
End Sub
此代码是EXCEL中的VBA，打开一个WORD模板文件，把里面所有的标签按表格内容进行替换，然后生成表格里面指定的名字的文件。
这个代码，这么贴出来，可7a64e78988e69d83338读性太差了吧？
不能替换的原因：
excel中的内容和word文档中的内容不能匹配；
excel中的字符串含有很多空格，而WORd中没有，多以find不到，因此不能做Replace。
检查下文档就好了。
另外，代码我也帖一个吧。
Sub test1()
iweizhi = 14
'生成合同文件
Dim yangbenpath As String
yangbenpath = Application.ActiveWorkbook.Path & Sheets("明细").Cells(iweizhi, 23).Value '获取修改文件《测试.doc》的位置
Dim deskpath As String
Dim weizhi As Variant
Dim WdApp, Wd, i%, Rng
Rng = Sheets("明细").Range("W23:X32")
Application.ScreenUpdating = False
Set WdApp = CreateObject("word.application")
WdApp.Visible = True
With WdApp.Documents.Open(yangbenpath)
WdApp.Visible = True
With .Content
For i = 1 To UBound(Rng)
If .Find.Execute(Rng(i, 1)) Then
.Text = Rng(i, 2)
End If
Next i
End With
.SaveAs "C:\2.doc"
End With
' deskpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" '获取桌面位置路径
' Wd.SaveAs deskpath & Sheets("明细").Cells(3, 24).Value & ".doc" '另存到桌面，文件名称为合同名
WdApp.Visible = True
Set Wd = Nothing
Set WdApp = Nothing
Application.ScreenUpdating = True
End Sub