分享:文件夹替换(通配符型)

konggs

Sub 孤独一叶()
'代码主要部分是原来老大的文件夹替换
'作用: 2开头前加2如0769-2开头前加2为0769-22******
'其他加8如0769-3、5、6、7、8前加8为0769-83******或0769-85******等
'功能: 查找文件夹并替换
Dim MyFind1 As String, MyRep1 As String
Dim MyFind2 As String, MyRep2 As String
Dim myfind As String, myrep As String
Dim i As Integer, aStory As Variant
Dim MyDialog As FileDialog, vrtSelectedItem As Variant, Doc As Document

On Error Resume Next
MyFind1 = "([0-9]{4}-)2([0-9]{6})"
MyFind2 = "([0-9]{4}-)([3567][0-9]{6})"
MyRep1 = "\122\2"
MyRep2 = "\18\2"
'定义一个文件夹选取对话框
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择

If .Show = -1 Then '确定
Application.ScreenUpdating = False
For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
Set Doc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
With Doc
For Each aStory In .StoryRanges '在文档的各个文字部分
For i = 1 To 2
myfind = IIf(i = 1, MyFind1, MyFind2)
myrep = IIf(i = 1, MyRep1, MyRep2)
With aStory.Find '指定区域范围中的查找与替换
.ClearFormatting '清除格式
.MatchWildcards = True '通配符为真
.Text = myfind
.Execute replacewith:=myrep, Replace:=wdReplaceAll '根据定义进行全部替换
End With
Next
Next
Doc.Close True '关闭文档
End With
Next vrtSelectedItem
End If
End With
Application.ScreenUpdating = True

Set Doc = Nothing '释放变量
End Sub

konggs

续二:

利用excel来批量替换

Option Explicit

Sub excel中的批量替换()
'利用excel来批量替换,
'复制到excel的模块中,采用前期绑定
'形式是在excel的第一列第一行输入"查找",第二列第二行输入"替换"
'从第二行开始为要查找的内容,和要替换的内容.
'此替换包括通配符,若再改进为四列,则可以包括不使用通配的替换方式
'因为数组不熟,没有用数组,速度上面有问题,等以后改进
Dim xfind As Long, xrep As Long, a As Long
Dim xfind1 As Long, xrep1 As Long
Dim wd As Word.Application
Dim doc As Word.Document
Dim afind As String, arep As String

xfind1 = Sheet1.Range("a65536").End(xlUp).Row
xrep1 = Sheet1.Range("b65536").End(xlUp).Row
'此为一对话框,可以不用
MsgBox "请注意查找与替换一一个对应,替换没有就是空!", vbOKCancel, "excelhome之家"
'创建word的实例（打开Word程序）
Set wd = New Word.Application

'添加一个Word文档
Set doc = wd.Documents.Open(Filename:="d:\0768.doc") '要打开的Word文档,用户自已改

For a = 2 To xfind1
afind = Sheet1.Cells(a, 1).Value
arep = Sheet1.Cells(a, 2).Value
'查找替换在此Word文档中

With doc.Content.Find
.ClearFormatting '清除格式
.MatchWildcards = True
.Text = afind
.Execute replacewith:=arep, Replace:=wdReplaceAll '根据定义进行全部替换
End With
Next
doc.SaveAs "d:\123.doc" '另存为一个文档,防止破坏原文档.如果你确定不要另存则可删除此句
'但保险起见,最好留着
doc.Close
'释放变量
Set doc = Nothing
Set wd = Nothing
End Sub

gues1688

不错，谢谢！