删除中文段落2020-10-11

Sub 删除中文段落()
    On Error Resume Next
    Dim i As Paragraph
    For Each i In ActiveDocument.Paragraphs
        If i.Range Like "*" & Chr(13) & Chr(7) Then
            i.Range.Font.Color = wdColorRed
            i.Range.Select
            Selection.MoveEnd unit:=wdCharacter, Count:=-1
            Selection.InsertParagraphAfter
        Else
            If i.Range Like "*[一-龥]*" Then i.Range.Delete
        End If
    Next
    
'再执行一遍
    For Each i In ActiveDocument.Paragraphs
        If i.Range Like "*" & Chr(13) & Chr(7) Then
            i.Range.Font.Color = wdColorRed
            i.Range.Select
            Selection.MoveEnd unit:=wdCharacter, Count:=-1
            Selection.InsertParagraphAfter
        Else
            If i.Range Like "*[一-龥]*" Then i.Range.Delete
        End If
    Next

'Sub 表格空段删除()
    Dim t As Table, c As Cell, v As Long, p As Paragraph, x As Range
    For Each t In ActiveDocument.Tables
        For Each c In t.Range.Cells
            v = c.Range.Paragraphs.Count
            If v > 1 Then
                '循环处理(不含最后一段)
                Set x = ActiveDocument.Range(Start:=c.Range.Paragraphs(1).Range.Start, End:=c.Range.Paragraphs(v - 1).Range.End)
                For Each p In x.Paragraphs
                    If Len(p.Range) = 1 Then p.Range.Delete
                Next
                '最后一段(字长=2则空白)
                If Len(c.Range.Paragraphs(c.Range.Paragraphs.Count).Range) = 2 Then
                    c.Range.Paragraphs(c.Range.Paragraphs.Count - 1).Range.Characters.Last.Delete
                End If
            End If
        Next
    Next
End Sub