求一个查找文档内多余的标点符号并把它们改为蓝色的宏代码

413191246se

139：你第一个宏说有“编号”，但你的《附件》里我未见编号啊！
另外：你单独发帖中的问题，我现在有个《循环遍历文件夹——提取文件名》宏，能把所有文件名提取出来（当然默认是doc文档），改为 *.* 即可包括 PDF 等格式了，恐怕不能满足你的要求。

413191246se

139：请试试以下《拆分文档》代码（可能是本论坛高人--守柔版主 的作品）：
Sub 拆分文档()
    Dim oSrcDoc As Document, oNewDoc As Document
    Dim strSrcName As String, strNewName As String
    Dim oRange As Range
    Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
    Dim fso As Object
   
    Const nSteps = 2 ' 修改这里控制每隔几页分割一次
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    Set oRange = oSrcDoc.Content
   
    nTotalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
    oRange.Collapse wdCollapseStart
    oRange.Select
    For nIndex = 1 To nTotalPages Step nSteps
        Set oNewDoc = Documents.Add
        If nIndex + nSteps > nTotalPages Then
            nBound = nTotalPages
        Else
            nBound = nIndex + nSteps - 1
        End If
        For nSubIndex = nIndex To nBound
            oSrcDoc.Activate
            oSrcDoc.Bookmarks("\page").Range.Copy
            oSrcDoc.Windows(1).Activate
            Application.Browser.Target = wdBrowsePage
            Application.Browser.Next
            
            oNewDoc.Activate
            oNewDoc.Windows(1).Selection.Paste
        Next nSubIndex
        strSrcName = oSrcDoc.FullName
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
        fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps + 1) & "." & fso.GetExtensionName(strSrcName))
        oNewDoc.SaveAs strNewName
        oNewDoc.Close False
    Next nIndex
    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing
    MsgBox "结束!"
End Sub

13907933959

413191246se 发表于 2015-10-21 17:45
139：请试试以下《拆分文档》代码（可能是本论坛高人--守柔版主 的作品）：
Sub 拆分文档()
    Dim oSrc ...

师傅好！

我说的有编号（见附件，就是指文件名上的028--食鉴本草，028这个编号）。

感谢师傅为我提供这个宏，因为电脑配置低处理不了大文档（小的几百页，大的几千页），只有把它拆分成小文档处理后再合并，求师傅再编写一个把它们依顺序合并的宏，配对使用。要求是不能改变文件的格式。

师傅有个《循环遍历文件夹——提取文件名》宏，给我用一下看看，如不能达要求再求师傅修改。

师傅，我还有个宏要劳师傅，循环遍历文件夹——所有的段落标记、手动换行符改为黑色。

师傅、因徒弟事太多，又没有这方面的技术，只有奈皮求师傅了！

413191246se

Sub 循环遍历文件夹_提取文件名()
    On Error Resume Next
    Dim fd As FileDialog, i As Long, doc As Document, p As String, e As Long
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("是否处理文件夹 " & p & " ?", vbYesNo + vbExclamation, "循环遍历文件夹_提取文件名") = vbNo Then Exit Sub
    If MsgBox("是否提取文件名？（否则处理所有文件）", vbYesNo + vbExclamation, "循环遍历文件夹_提取文件名") = vbYes Then e = 1 Else e = 0
    Documents.Add '提取文件名
    With Application.FileSearch
        .NewSearch
        .LookIn = p
        .SearchSubFolders = True
        .FileName = "*.doc"
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                If e = 1 Then GoTo np
                Set doc = Documents.Open(FileName:=.FoundFiles(i))
                doc.Content.Font.Color = wdColorRed '处理单个文档(通用)
                doc.Close savechanges:=wdSaveChanges
np:
                ActiveDocument.Content.InsertAfter Text:=.FoundFiles(i) & vbCr '提取文件名
            Next i
            MsgBox "处理完毕！共处理 " & .FoundFiles.Count & " 个文件！", vbOKOnly + vbExclamation, "循环遍历文件夹_提取文件名"
        Else
            MsgBox "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹_提取文件名"
        End If
    End With
End Sub

413191246se

139：你看看，下面是单个文档——查找段落符号、换行符设置为黑色的代码：
Sub test()
'段落符号
    Selection.HomeKey Unit:=wdStory
    Do
        Selection.Find.Execute findtext:=vbCr
        If Selection.Find.Found = True Then
            Selection.Font.Color = wdColorBlack
            Selection.MoveEnd Unit:=wdCharacter, Count:=1
            If Len(Selection) > 1 Then Selection.MoveEnd Unit:=wdCharacter, Count:=-1 Else Exit Do
            Selection.MoveRight Unit:=wdCharacter, Count:=1
        End If
    Loop

'换行符
    Selection.HomeKey Unit:=wdStory
    Do
        Selection.Find.Execute findtext:="^l"
        If Selection.Find.Found = True Then
            Selection.Font.Color = wdColorBlack
            Selection.MoveEnd Unit:=wdCharacter, Count:=1
            If Len(Selection) > 1 Then Selection.MoveEnd Unit:=wdCharacter, Count:=-1 Else Exit Do
            Selection.MoveRight Unit:=wdCharacter, Count:=1
        Else
            Exit Do
        End If
    Loop
End Sub

413191246se

下面这是验证段落符、换行符是否为黑色的代码：（显示0即为黑色，255为红色）-----设置其为热键 F3 即可
Sub displaycolor()
'
' displaycolor Macro
' 宏在 2015/10/22 由 lenovo 录制
'
    MsgBox Selection.Font.Color
End Sub

13907933959

413191246se 发表于 2015-10-22 11:20
下面这是验证段落符、换行符是否为黑色的代码：（显示0即为黑色，255为红色）-----设置其为热键 F3 即可
S ...

师傅好！
Sub 循环遍历文件夹_提取文件名()，这个宏好象可以同时提取到文件夹名和文件名，师傅、有什么办法能够把文件夹内包含的 TXT、PDF、Excel 这 3 种格式的文件名也提取到，如能每个文件夹的文件名能单独编一下号就理想了。

师傅，这个单个文档——查找段落符号、换行符设置为黑色的代码，基本能达到要求，但因我现有一万多个文件要处理（前面处理时留下的隐患），如一个个处理还是非常费时间，还得请师傅再帮徒弟把它改为循环遍历文件夹的宏。另外昨天我有一点没有说清楚，请师傅在宏中原来在查找段落符号、手动换行符时不用鉴别颜色，加几句可鉴别颜色（颜色可换）的代码，不用鉴别时可屏蔽掉。

谢谢师傅考虑周全，还为我编写了一个：验证段落符、换行符是否为黑色的宏！谢谢！

loquat

1. Dim aFolder$, aNum&, arr, i&, aDoc As Document
   
2. With Application.FileDialog(msoFileDialogFolderPicker)  '选择目录
   
3.     aFolder = .SelectedItems(1)
   
4.     If Right(aFolder, 1) <> "" Then aFolder = aFolder & ""
   
5. End With
   
6. aFolder = """" & aFolder & """"
   
7. With CreateObject("WScript.Shell")   '遍历结果到文件
   
8.     .Run Environ$("comspec") & " /c dir " & aFolder & " /s /a:-d /b > C:\aTemp.txt", 0, True
   
9.     aNum = FreeFile
   
10.     Open "C:\aTemp.txt" For Input As #aNum  '读取文件
    
11.         arr = Split(StrConv(InputB(LOF(aNum), aNum), vbUnicode), vbCrLf)
    
12.     Close #aNum
    
13.     .Run Environ$("comspec") & " /c delele /f /q C:\aTemp.txt", 0, True  '删除临时文件
    
14. End With
    
15. For i = 1 To UBound(arr) - 1  '循环处理文件
    
16.     Set aDoc = Documents.Open(arr(i))
    
17.     With aDoc.Content.Find
    
18.         .ClearFormatting
    
19.         .Replacement.ClearFormatting
    
20.         .Replacement.Font.ColorIndex = wdBlue
    
21.         .Text = "[，。！？：；、.]{2,}"
    
22.         .Forward = True
    
23.         .Wrap = wdFindStop
    
24.         .Format = True
    
25.         .MatchWildcards = True
    
26.         .Execute Replace:=wdReplaceAll
    
27.     End With
    
28. Next
    
29. Application.ScreenUpdating = True

复制代码

13907933959

loquat 发表于 2015-10-22 13:18

前辈好！
感谢前辈出手相助！这个代码怎样才能运行？
由于本人是个菜鸟，水平不够，录制了一个宏，把代码拷贝进去也运行不了，请前辈再赐教！谢谢！

413191246se

139：高人 loquat 的代码，需要你自己创建一个宏，把他的代码拷贝到该宏里面运行即可。
另外：上面单个文档查找段落符/换行符的代码，你舍弃第一行和最末行（即 Sub.../End Sub这两行），把其它行拷贝到上面《循环遍历文件夹--提取文件名》这个宏中，替换下面这句代码：
doc.Content.Font.Color = wdColorRed '处理单个文档(通用)