Microsoft Office Forums - View Single Post

genja · 12-04-2024, 12:56 PM

Thanks Greg, that put me in the right direction. I thought that I can target the paragraph within the cc specifically but now I just iterate through the entire document.

My goal is to find all empty paragraphs in documents with 3000 (or sometimes more) paragraphs that do not contain necessary breaks and delete them. Tables are excluded by design. There is some redundancy in the code regarding the checking for the breaks which I was too lazy to remove. I am fairly new to VBA, so, if anyone has a suggestion for improvement, please share your thoughts.

Code:

Sub delete_empty_paras()
 Dim doc As Document, para As Paragraph, paraNext As Paragraph, paraRng As Range, _
 paraLen As Integer, delCount As Integer, paraCount_pre As Integer, paraCount_post As Integer
     StartTime = Timer
    Set doc = ActiveDocument: Set para = doc.Paragraphs.First
    Do While Not para Is Nothing
        Set paraNext = para.Next
        If para.Range.Tables.count > 0 Then GoTo Skip
        Set paraRng = para.Range: paraLen = Len(para.Range.text)
        If paraRng.text = ChrW(12) Then GoTo Skip:If paraRng.text = "^m" Then GoTo Skip
        If paraLen <= 2 Then
            If Not ContainsBreaks(paraRng) And Not ContainsShapesOrImages(paraRng) Then
                paraCount_pre = doc.Paragraphs.count
                'paraRng.Select 'debugging
                paraRng.Delete: paraCount_post = doc.Paragraphs.count: del = IIf(paraCount_post <> paraCount_pre, 1, 0)
                delCount = delCount + del
            End If
        End If
Skip:
        Set para = paraNext
    Loop
     Debug.Print "Paragraphs deleted: " & delCount & "  |  Execution time: " &  _
                  Round(Timer - StartTime, 2) & " s  |  " & Format((Timer - StartTime) / 60, "0.00") & " min"
   End Sub

Code:

Function ContainsShapesOrImages(rng As Range) As Boolean
    Dim iLshp As InlineShape, shp As shape
    Dim found As Boolean
    found = False
    For Each iLshp In rng.InlineShapes 'check for InlineShapes
        found = True: Exit For
    Next iLshp
    If Not found Then 'check for regular shapes. do I even need this?
        For Each shp In rng.ShapeRange
            found = True: Exit For
        Next shp
    End If
    ContainsShapesOrImages = found
End Function

Code:

Function ContainsBreaks(rng As Range) As Boolean
     Dim searchText As Variant, found As Boolean, i As Integer
    searchText = Array("^b", "^m", "^12", "^n") 'checks for specific breaks
    found = False
    With rng.Find
        .ClearFormatting: .Forward = True: .Wrap = wdFindStop: .MatchWildcards = False
        For i = LBound(searchText) To UBound(searchText)
            .text = searchText(i)
            If .Execute Then: found = True: Exit For 'exit when found
        Next i
    End With
    ContainsBreaks = found
 End Function

Code:

 Function StopTimer(StartTime As Double) As Double
    Dim elapsedTime As Double
    elapsedTime = Timer - StartTime
    StopTimer = elapsedTime
End Function