|
本帖最后由 釜底抽薪 于 2021-12-6 22:26 编辑
表格中 A2 是要查找的内容
B2 是要替换的内容
就是替换不起 求大神帮忙指导下
Sub 批量写入()
Dim ar
ar = [{"查找字符","替换字符"}]
[a1].Resize(, UBound(ar)) = ar
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择要处理的数据所在的文件夹"
If .Show Then
mypath = .SelectedItems(1)
Else
MsgBox "对不起,你没有告诉我要处理的工作簿在哪个文件夹", vbExclamation, "温馨提示"
Exit Sub
End If
End With
mypath = IIf(Right(mypath, 1) <> "\", mypath & "\", mypath)
myname = Dir(mypath & "*.doc*")
Application.ScreenUpdating = True
Do While myname <> ""
Set wdapp = CreateObject("word.application")
wdapp.Documents.Open Filename:=mypath & myname
wdapp.Visible = True
wdapp.Selection.Find.Replacement.ClearFormatting
With wdapp.Selection.Find
.Text = Range("A2")
.Replacement.Text = Range("B2")
End With
wdapp.Selection.Find.Execute Replace:=wdReplaceAll
wdapp.Documents.Save
wdapp.Application.Quit
Set wdapp = Nothing
myname = Dir
Loop
Application.ScreenUpdating = False
MsgBox "完成替换"
End Sub
Sub 批量写入()
Dim ar, con, word
ar = [{"查找字符","替换字符"}]
[a1].Resize(, UBound(ar)) = ar
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择要处理的数据所在的文件夹"
If .Show Then
mypath = .SelectedItems(1)
Else
MsgBox "对不起,你没有告诉我要处理的工作簿在哪个文件夹", vbExclamation, "温馨提示"
Exit Sub
End If
End With
mypath = IIf(Right(mypath, 1) <> "\", mypath & "\", mypath)
myname = Dir(mypath & "*.docx*")
Set wdapp = CreateObject("word.application")
Do While myname <> ""
Set word = wdapp.Documents.Open(Filename:=mypath & myname)
Set con = word.Content
con.Find.Execute findtext:=Range("A2").Value, replacewith:=Range("B2").Value, Replace:=2
word.Save
word.Close
Set word = Nothing
myname = Dir
Loop
wdapp.Application.Quit
Set wdapp = Nothing
MsgBox "完成替换"
End Sub
|
-
-
1.zip
362.62 KB, 下载次数: 27
|