如何用vba批量替换字体

yangzehao

我想把一个word文档里全部的仿宋字体替换为宋体，三号，默认颜色。

搜索半天也搜不到相关内容。
按照网上教的用录制宏和word自带的查找替换功能把字体格式设定后全部替换。但录制的宏运行后无效。
求大佬帮忙

batmanbbs

发个样本上来测试一下，一般情况查找替换字体格式都没有问题

zhgj007

也不知道你到底想做什么？
改编一个，看是否符合你的要求。
Sub aa()
    With ActiveDocument.Content
        .Find.Font.Name = "仿宋"
        Do While .Find.Execute
            n = n + 1
            .Find.Parent.Editors.Add -1
        Loop
        If n > 0 Then
            .GoToEditableRange.Editors(1).SelectAll
            .GoToEditableRange.Editors(1).DeleteAll
     
        End If
    End With
    Selection.Font.Name = "宋体"
    Selection.Font.Size = 16
    Selection.Font.Color = wdColorAutomatic
     Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub

yangzehao

batmanbbs 发表于 2023-7-31 17:53
发个样本上来测试一下，一般情况查找替换字体格式都没有问题

手动查找替换没问题，现在想要的是用vba来批量替换，因为文件数量几百个，全手工替换比较累人

yangzehao

zhgj007 发表于 2023-7-31 19:41
也不知道你到底想做什么？
改编一个，看是否符合你的要求。
Sub aa()

我在汇总处理学校晋级升等的材料。要求全部按公文格式排版。
学校各处室交来的材料格式不一，有一个科室交的几百份材料都是没有仿宋GB-XXXX字体，所以它就全部用仿宋字体代替。要一个个去查找替换太蛋疼了。。。

zhgj007

yangzehao 发表于 2023-7-31 21:00
我在汇总处理学校晋级升等的材料。要求全部按公文格式排版。
学校各处室交来的材料格式不一，有一个科室 ...

一会换为宋体，一会换为黑体，再发你一个换为黑体的。不用谢。
Sub 仿宋替换为黑体()
    With ActiveDocument.Content
        .Find.Font.Name = "仿宋"
        Do While .Find.Execute
            n = n + 1
            .Find.Parent.Editors.Add -1
        Loop
        If n > 0 Then
            .GoToEditableRange.Editors(1).SelectAll
            .GoToEditableRange.Editors(1).DeleteAll
     
        End If
    End With
    Selection.Font.Name = "黑体"
    Selection.Font.Size = 16
    Selection.Font.Color = wdColorAutomatic
     Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub

shenjianrong163

过客fppt

用VBA的fso对所有文件执行同样的代码操作，这样就不用手动一个一个打开替换了

batmanbbs

注意：没有后悔药，自己做好备份

相见是缘8

batmanbbs 发表于 2023-8-1 17:03
注意：没有后悔药，自己做好备份

batmanbbs 老师好！

代码在我这运行不了，不知抄错在哪？

Sub 批里替换WORD文档中的字体()

    '将文件夹内所有WORD文档中的仿宋替换为宋体。

    Dim myDoc As Document

    Dim myPath$, myFile$, FindFont$, ReplFont$, i%

    With Application.FileDialog(msoFileDialogFolderPicker)

        .Title = "选择目标文件夹"

        If .Show <> -1 Then Exit Sub

        myPath = .SelectedItems(1) & "\"

    End With

    Application.ScreenUpdating = False

    FindFont = "仿宋": ReplFont = "宋体"

    myFile = Dir(myPath & "*.doc?")

    Do While myFile <> ""

        On Error Resume Next

        Set myDoc = Documents.Open(myPath & myFile, Visible:=False)

        On Error GoTo 0

        If myDoc Is Nothing Then Set myDoc = Documents(myPath & myFile)

        With myDoc

            With .Content.Find

                .ClearFormatting

                .Forward = True

                .Wrap = wdFindContinue

                .Format = True

                .Font.NameFarEast = FindFont

                With .Replacement

                    .ClearFormatting

                    With .Font

                        .NameFarEast = ReplFont

                        .Size = 16

                        .Color = wdColorAutomatic

                    End With

                End With

                .Execute Replace:=wdReplaceAll

            End With

            .Save: .Close: i = i + 1

        End With

        Set myDoc = Nothing

        myFile = Dir

    Loop

    Application.ScreenUpdating = True

    MsgBox "共转换" & i & "个文件"

End Sub