字符某一颜色删除

T-T-J

我有一批WORD文档，在集中有某些文件中有红色字符的字，这是用于注释的，但我现在想用批量删除的方法，把凡是红色字符的字全部删除，而其他颜色的字符保留，请哪位帮我用VBA做一下批量删除某一颜色的字符

413191246se

楼主，建议提供一份附件才好，如果批注中含有红色字符，我不清楚能不能删除它。批注不懂。

daibao88

上文档吧，不知道说的是角注还是尾注。

T-T-J

请大咖帮一帮忙!!!
我有一批WORD文档，在集中有某些文件中有红色字符的字，这是用于注释的，但我现在想用批量删除的方法，把凡是红色字符的字全部删除，而其他颜色的字符保留，请哪位帮我用VBA做一下批量删除某一颜色的字符

相见是缘8

T-T-J 发表于 2019-8-6 22:52
请大咖帮一帮忙!!!
我有一批WORD文档，在集中有某些文件中有红色字符的字，这是用于注释的，但我现在想用 ...

Sub 删除红色字符()
    With ActiveDocument.Content.Find
        .Font.Color = wdColorRed
        .Execute FindText:="", replacewith:="", Format:=True, Replace:=wdReplaceAll
    End With
End Sub

413191246se

* 楼主，请备份后应用下面的宏：（借用 相见是缘 的代码一下，谢谢！）

1. Sub aaab_FSO_循环遍历文件夹_删除红色字符()
   
2. 
   
3.     On Error Resume Next
   
4. 
   
5.     Dim objShell As Object, objFolder As Object, pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, n&, stxt$, doc As Document, x&
   
6. 
   
7.     Set objShell = CreateObject("Shell.Application")
   
8.     Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
   
9. 
   
10.     pPath = objFolder.self.Path & ""
    
11. 
    
12.     Set objShell = Nothing
    
13.     Set objFolder = Nothing
    
14. 
    
15.     If MsgBox("请确认！是否处理文件夹 " & pPath & " ?", 4 + 16) = vbNo Then Exit Sub
    
16. 
    
17.     Set fso = CreateObject("Scripting.FileSystemObject")
    
18. 
    
19.     top = 1
    
20.     ReDim Stack(0 To top)
    
21. 
    
22.     Do While top >= 1
    
23.         For Each f In fso.GetFolder(pPath).Files
    
24.             n = n + 1
    
25.             stxt = f.Path
    
26.             If stxt Like "*.doc*" Then
    
27.                 Set doc = Documents.Open(FileName:=stxt, Visible:=False)
    
28. '''
    
29.                 '删除所有域/删除红色字符
    
30.                 With doc
    
31.                     .Fields.Unlink
    
32.                     With .Content.Find
    
33.                         .Font.Color = wdColorRed
    
34.                         .Execute FindText:="", replacewith:="", Format:=True, Replace:=wdReplaceAll
    
35.                     End With
    
36.                     ActiveWindow.ActivePane.View.Zoom.Percentage = 89
    
37.                     .Close SaveChanges:=wdSaveChanges
    
38.                 End With
    
39. '''
    
40.                 x = x + 1
    
41.             End If
    
42.         Next
    
43.         For Each fd In fso.GetFolder(pPath).SubFolders
    
44.             Stack(top) = fd.Path
    
45.             top = top + 1
    
46.             If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
    
47.         Next
    
48.         If top > 0 Then pPath = Stack(top - 1): top = top - 1
    
49.     Loop
    
50. 
    
51.     Set f = Nothing
    
52.     Set fd = Nothing
    
53.     Set fso = Nothing
    
54. 
    
55.     MsgBox "文件夹包含 " & n & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
    
56. End Sub

复制代码