Word排版跳过表格的代码，提高效率

19820713chen

参照下面的代码：

Sub ChooseContent()
    Dim rng As Range
    Dim sArr() As Variant
    Dim eArr() As Variant
    Dim ListC, TableC, FieldC, InshapeC, Cnt As Integer
   
    With ActiveDocument
        ListC = .ListParagraphs.Count
        TableC = .Tables.Count
        FieldC = .Fields.Count
        InshapeC = .InlineShapes.Count
        Cnt = ListC + TableC + FieldC + InshapeC
        ReDim sArr(Cnt - 1)
        ReDim eArr(Cnt - 1)
        
        If ListC <> 0 Then  '获取带列表的段落位置
            For i = 0 To ListC - 1
                sArr(i) = .ListParagraphs.Item(i + 1).Range.Start
                eArr(i) = .ListParagraphs.Item(i + 1).Range.End
            Next
        End If
        
        If TableC <> 0 Then '获取表格的位置
            For i = ListC To ListC + TableC - 1
                sArr(i) = .Tables.Item(i + 1 - ListC).Range.Start - 1
                eArr(i) = .Tables.Item(i + 1 - ListC).Range.End
            Next
        End If
        
        If FieldC <> 0 Then '获取题注的位置
            For i = ListC + TableC To ListC + TableC + FieldC - 1
                sArr(i) = .Fields.Item(i + 1 - ListC - TableC).Result.Paragraphs(1).Range.Start
                eArr(i) = .Fields.Item(i + 1 - ListC - TableC).Result.Paragraphs(1).Range.End
            Next
        End If
         
        If InshapeC Then  '获取内嵌图片位置
            For i = ListC + TableC + FieldC To ListC + TableC + FieldC + InshapeC - 1
                sArr(i) = .InlineShapes.Item(i + 1 - ListC - TableC - FieldC).Range.Start
                eArr(i) = .InlineShapes.Item(i + 1 - ListC - TableC - FieldC).Range.End + 1
            Next
        End If
        
        Call BubbleSort(sArr, Cnt - 1) '排序
        Call BubbleSort(eArr, Cnt - 1)
        
        If sArr(0) <> 0 Then  '前文字
            Set rng = .Range(Start:=0, End:=sArr(0))
            rng.Editors.Add wdEditorEveryone
        End If
        
        For i = 0 To Cnt - 2 '间文字
             If eArr(i) < sArr(i + 1) Then
                Set rng = .Range(Start:=eArr(i), End:=sArr(i + 1))
            End If
            rng.Editors.Add wdEditorEveryone
        Next
        
        If eArr(Cnt - 1) <> .Range.End Then '后文字
            Set rng = .Range(Start:=eArr(Cnt - 1), End:=.Range.End)
           
        End If
        .SelectAllEditableRanges wdEditorEveryone
        .DeleteAllEditableRanges wdEditorEveryone

        
    End With
End Sub

Function BubbleSort(ByRef byArr() As Variant, bySize As Integer)
    Dim TEMP As Variant
    For i = 0 To bySize - 2
        For j = i + 1 To bySize - 1
            If byArr(i) > byArr(j) Then
                TEMP = byArr(j)
                byArr(j) = byArr(i)
                byArr(i) = TEMP
            End If
        Next j
    Next i
End Function

19820713chen

简单参照下面代码：
Sub 选择所有不含表格的段落图片()
   
    Application.ScreenUpdating = False
    Dim starTimer As Long
    Dim tempStr As String
    starTimer = Timer
    Dim i%, myRange()
   
    '选择所有不含表格的段落
    With ActiveDocument
        ReDim myRange(.Tables.Count + 1)
        If .Tables.Count > 0 Then
            Set myRange(0) = .Range(0, 0)
            For i = 1 To .Tables.Count
                If i = 1 Then
                    Set myRange(i) = .Range(0, .Tables(i).Range.Start)
                Else
                    Set myRange(i) = .Range(.Tables(i - 1).Range.End, .Tables(i).Range.Start)
                End If
            Next
            Set myRange(i) = .Range(.Tables(i - 1).Range.End, .Content.End)
        Else
            Set myRange(1) = .Content
        End If
    End With
     
    '选择不含图片的段落
    For i = 1 To UBound(myRange)
        
        For Each myPara In myRange(i).Paragraphs
            tempStr = myPara.Range.text
            
                If Len(tempStr) >= 3 Then
                    myPara.Range.Editors.Add wdEditorEveryone
                End If
        Next
    Next
    ActiveDocument.SelectAllEditableRanges wdEditorEveryone
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
   
    MsgBox "作业完成,用时:" & Int(Timer - starTimer) & "秒"
    Application.ScreenUpdating = True
      
End Sub

cjan520

感谢分享。