用VBA设置WORD文档所有字母和数字字体

39660519 · 发表于 2016-9-21 11:56

本帖最后由 39660519 于 2016-9-21 16:45 编辑

各位老师：
我的当前文件夹里有N个WORD文档，每个文档里有很多字母和数字，现在我想把所有文档里的字母和数字字体设置成"Times New Roman"。开始我用WORD录制宏再改写（绿色代码部分）但不成功，老师们帮我看看。后来就每个字节用正则判断，成功了，但速度超慢，老师们帮帮我

Sub 字体转换()
Application.ScreenUpdating = False  '关平屏幕刷新
Application.DisplayAlerts = False '在程序执行过程中使出现的警告框不显示
On Error Resume Next

格式 = ".doc" '格式 = ".docx"
地址 = ThisWorkbook.Path & "\"

Set WORD对象 = CreateObject("Word.Application")  '后期绑定
With WORD对象
      .Visible = True  '表格可见

      N = 6
      For B = 1 To N

         Set WORD文件 = WORD对象.Documents.Open(地址 & B & 格式)
         WORD文件.Characters(1).Select

         'WORD对象.Selection.Find.ClearFormatting
         'WORD对象.Selection.Find.Replacement.ClearFormatting
         'With WORD对象.Selection.Find
            '.Text = "([0-9A-Za-z]{1,})"
            '.Replacement.Text = ""
            '.Forward = True
            '.Wrap = wdFindContinue
            '.Format = True
            '.MatchCase = False
            '.MatchWholeWord = False
            '.MatchByte = True
            '.MatchWildcards = False
            '.MatchSoundsLike = False
            '.MatchAllWordForms = False
         'End With
         'Do
            'WORD对象.Selection.Find.Execute ' 下一个
            'If WORD对象.Selection.Font.Name = "宋体" Then
                  'WORD对象.Selection.Font.Name = "Times New Roman" '字体
            'Else
                  'Exit Do
            'End If
         'Loop

         Set 正则对象 = CreateObject("VBSCRIPT.REGEXP")
         正则对象.Global = True
         正则对象.MultiLine = True
         正则对象.IgnoreCase = True
         正则对象.Pattern = "[0-9A-Z]"
         A = WORD文件.Characters.Count
         For A1 = 1 To A
            T = WORD文件.Characters(A1).Text
            If 正则对象.Test(T) = True Then
                  WORD文件.Characters(A1).Font.Name = "Times New Roman"
            End If
         Next A1

         WORD文件.SaveAs Filename:=地址 & B & 格式  '另存为
         WORD文件.Close '关闭文档
      Next B
      .Quit    '退出Word对象
End With

Application.DisplayAlerts = True    '在程序执行过程中显示警告框
Application.ScreenUpdating = True '打开屏幕刷新
End Sub

小花鹿 · 发表于 2016-9-21 13:00

查找替换就行吧：

duquancai · 发表于 2016-9-21 13:36

请下载附件打开“文档.docm”，点击按钮进行测试》》》》

39660519 · 发表于 2016-9-21 13:38

小花鹿发表于 2016-9-21 13:00
查找替换就行吧：

谢谢小花鹿，有500多个文档，后续还会增加，一个一个太费时间，也怕漏掉

39660519 · 发表于 2016-9-21 13:48

duquancai 发表于 2016-9-21 13:36
请下载附件打开“文档.docm”，点击按钮进行测试》》》》

谢谢老师，我现在想用EXCEL操作修改WORD文档，代码要怎么写？

duquancai · 发表于 2016-9-21 13:52

为啥非要用Excel？

duquancai · 发表于 2016-9-21 13:53

本帖最后由 duquancai 于 2016-9-21 13:55 编辑

39660519 发表于 2016-9-21 13:48
谢谢老师，我现在想用EXCEL操作修改WORD文档，代码要怎么写？

为啥非要用Excel？歧视word吗？

39660519 · 发表于 2016-9-21 13:57

duquancai 发表于 2016-9-21 13:53
为啥非要用Excel？

因为我很多数据保存在EXCEL里面，我要自动生成需要文件，因为公司统一文件格式，所以要用EXCEL,能给我你QQ吗？我发原件给你

39660519 · 发表于 2016-9-21 13:57

duquancai 发表于 2016-9-21 13:52
为啥非要用Excel？

因为我很多数据保存在EXCEL里面，我要自动生成需要文件，因为公司统一文件格式，所以要用EXCEL,能给我你QQ吗？我发原件给你

duquancai · 发表于 2016-9-21 14:20

39660519 发表于 2016-9-21 13:57
因为我很多数据保存在EXCEL里面，我要自动生成需要文件，因为公司统一文件格式，所以要用EXCEL,能给我你Q ...

Sub shishi()
Dim pt$, f$, wd As Object, n&, m&, wdapp As Object
Dim Arng As Object, oRang As Object, mt
Application.ScreenUpdating = False
Set wdapp = CreateObject("Word.Application")
wdapp.Visible = False
pt = ThisWorkbook.Path & ""
f = Dir(pt & "*.doc*")
Do While f <> ""
Set wd = wdapp.Documents.Open(pt & f, Visible:=False)
Set Arng = wd.Content
With CreateObject("vbscript.regexp")
.Pattern = "[a-zA-Z0-9]+"
.Global = True: .IgnoreCase = False
For Each mt In .Execute(Arng)
m = mt.FirstIndex: n = mt.Length
Set oRang = wd.Range(m, m + n)
oRang.Font.Name = "Times New Roman"
Next
End With
wd.Close True
f = Dir
Loop
wdapp.Quit
MsgBox "操作完毕！"
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[已解决] 用VBA设置WORD文档所有字母和数字字体

评分

评分