网页或PDF等复制文本的格式快速规范

1. 从网页或者PDF等复制文本到Word的时候，往往会夹杂很多 空格、空行、多余段落标记、手动换行符、引用标记、全角数字和部分全角的英文标点
2. 按照以下步骤配置能够一键检测并删除或更正。

一、模块使用效果预览

二、使用前配置步骤

1）把代码粘贴到Word

1. 复制文末的代码，打开Word，使用快捷键Alt+F11；

2. 在新打开的窗口右键Normal，点击插入(N)、模块(M)；
   

3. 粘贴刚刚复制的代码，然后Ctrl+S保存，并关闭当前窗口；
   

2）添加按钮到快速访问工具栏

1. 右键点击快速访问工具栏的任意一个功能，如撤销，接着点击自定义快速访问工具栏；
   
2. 在新打开的窗口依次点击常用命令右边的倒三角和宏，然后在下面找到Normal.模块1.format，左键双击回车，按钮就会出现在快速访问工具栏；
   

三、关于该功能使用的一些说明

1. 检测到问题之后会弹出窗口，点击否会跳过这个问题；点击取消或者右上角的叉叉可以直接结束，不再检测问题；
2. 选中文本的时候，不用全部选中，只要保证需要处理的段落，每一段都选了一点，就可以处理这些段落里面的问题，可以像下图一样选择。
   
3. 如果有任何使用问题或者有其他好的想法，欢迎私信和评论，会尽快回复和更新代码。

四、VBA代码

Public continue As Boolean, times As Boolean, orange As Range

Function wait(time As Double)
    pt = time: st = Timer
    Do While Timer < st + pt
        DoEvents
    Loop
End Function

Function delete_error(find As String, replace As String, alert1 As String, alert2 As String, Optional other_situation As Byte = 2)
    Dim error As Boolean
    error = False
    Select Case other_situation
        Case 1
            For Each i In Selection.Paragraphs
                If Len(i.Range) = 1 Then '判断段落长度
                    error = True
                    Exit For
                End If
            Next
        Case 2
            Selection.find.Execute Wrap:=wdFindStop, findtext:=find, replace:=wdReplaceNone, replacewith:="", MatchWildcards:=True
            If Selection.find.Found Then
               error = True
            End If
        Case 3
            For Each i In Array("([!a-zA-Z]) {1,}", " {1,}([!a-zA-Z])", "([a-zA-Z]) {2,}", "[　]")
                Selection.find.Execute Wrap:=wdFindStop, findtext:=i, replace:=wdReplaceNone, replacewith:="", MatchWildcards:=True
                orange.Select
                If Selection.find.Found Then
                   error = True
                   Exit For
                End If
            Next
        Case 4
            Selection.find.Execute Wrap:=wdFindStop, findtext:=find, replace:=wdReplaceNone, replacewith:="", MatchWildcards:=True
            If Selection.find.Found Then
               error = True
            End If
    End Select
    orange.Select
    If error And continue Then
        times = False
        Select Case MsgBox(alert1, vbYesNoCancel + vbExclamation, alert2)
            Case vbCancel
                continue = False
            Case vbYes
                Application.ScreenUpdating = False '关闭屏幕更新
                Selection.Expand Unit:=wdParagraph
                Select Case other_situation
                    Case 1
                        For Each i In Selection.Paragraphs
                            If Len(i.Range) = 1 Then '判断段落长度
                                i.Range.delete
                            End If
                        Next
                    Case 2
                        Selection.find.Execute Wrap:=wdFindStop, replace:=wdReplaceAll, MatchWildcards:=True, replacewith:=replace, findtext:=find
                    Case 3
                        Selection.find.Execute Wrap:=wdFindStop, replace:=wdReplaceAll, MatchWildcards:=True, replacewith:=" ", findtext:="[　]"
                        Selection.find.Execute Wrap:=wdFindStop, replace:=wdReplaceAll, MatchWildcards:=True, replacewith:="\1", findtext:="([!a-zA-Z]) {1,}"
                        Selection.find.Execute Wrap:=wdFindStop, replace:=wdReplaceAll, MatchWildcards:=True, replacewith:="\1", findtext:=" {1,}([!a-zA-Z])"
                        Selection.find.Execute Wrap:=wdFindStop, replace:=wdReplaceAll, MatchWildcards:=True, replacewith:="\1 ", findtext:="([a-zA-Z]) {2,}"
                    Case 4
                        Do
                            orange.Select
                            Selection.find.Execute Wrap:=wdFindStop, findtext:=find, replace:=wdReplaceNone, replacewith:="", MatchWildcards:=True
                            If Selection.find.Found Then
                                Selection.Range.CharacterWidth = wdWidthHalfWidth
                            End If
                        Loop While Selection.find.Found
                End Select
                Application.ScreenUpdating = True '恢复屏幕更新
                wait 0.05
        End Select
    End If
End Function
Sub format()
    Dim num_paragraph As Integer, plaintext As Boolean
    plaintext = False
    continue = True
    times = True
    
    Selection.Expand Unit:=wdParagraph
    Selection.ClearFormatting
    Selection.Style = ActiveDocument.Styles("正文")
    Selection.MoveEnd Unit:=wdCharacter, Count:=-1 '不取消选择最后一个段落标记的话，可能会被判断为多余或者空行
    Set orange = Selection.Range

    If Selection.Range.Text <> "" Then '如果没有选中任何东西，会报空行
        delete_error "", "", "检测到段落中有空行，是否删除，请确认！", "空行", 1 '要在段落标记之前删空行
    End If
    delete_error "([!！？。……：；)}】\!\?.;])^13", "\1", "检测到段落中有多余段落标记(一句话还未结束就换行)，是否删除，请确认！", "多余段落标记"
    orange.MoveEnd Unit:=wdCharacter, Count:=1 '不选中最后一个段落标记的话，如果选中部分只有一个空格，手动换行符，引用标记不会被检测到
    orange.Select
    delete_error "^l", "", "检测到段落中有手动换行符，是否删除，请确认！", "手动换行符"
    
    If Selection.Range.Text <> vbCr And continue Then '如果选择的东西是空的，没有东西可以粘贴，会报错
        plaintext = True
        '因为只保留文本的手动换行符会变成段落标记，段落就会变多，重新往前选择就会失效，所以在这个之前要保证没有手动换行符
        num_paragraph = Selection.Paragraphs.Count '剪切粘贴了之后，光标会移动到最后一个字符处，需要重新选中，所以在剪切之前记录选中的段落数
        Selection.Cut '要先扩展了之后再剪切，要在把手动换行符去掉了之后再剪切，
        Selection.PasteAndFormat (wdFormatPlainText)
        Selection.TypeText Text:=vbCr '粘贴只保留文本，会删除最后一个段落标记，补上
        Selection.MoveStart Unit:=wdParagraph, Count:=-num_paragraph '粘贴之后的重新往前选择
        Selection.ClearFormatting
        Selection.Style = ActiveDocument.Styles("正文") '粘贴了之后，样式可能会变成下一段的样式，再换回正文
        'Selection.MoveEnd unit:=wdCharacter, Count:=1 这里不需要往后选择1字符，因为上一句已经选择了
        Set orange = Selection.Range '这样会让之前保存的选区失效，所以搞完之后要再保存一次
    End If
    
    
    delete_error "", "", "检测到段落中有多余空格，是否删除(英文会保留一个)，请确认！", "多余空格", 3
    delete_error "\[[0-9\-,－，]{1,}\]", "", "检测到段落中有引用标记(如[2]、[3-5])，是否删除，请确认！", "引用标记"
    delete_error "[０-９ａ-ｚＡ-Ｚ．％｛｝＃＠＄＋＆＝]", "", "检测到段落中有全角数字或全角英文标点，是否改成半角，请确认！", "全角数字或全角英文标点", 4
    
    If Selection.Range.Text <> vbCr And plaintext Then
        Selection.MoveRight Unit:=wdCharacter, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        If Selection.Range.Text = vbCr Then
            Selection.delete
        End If '如果后面一个字符是回车，那么就是刚刚只保留文本粘贴时多输入的回车，现在删掉
        orange.Select '重新选中
    End If
    
    If times Then
        MsgBox "未发现错误"
    End If
End Sub