How to remove Top blank lines in VBA office word

Question

How i can delete Only the blank lines at the top of each page in VBA word 2016.

I tried to do something like this

Sub RemoveBlankParas()
    Dim para As Paragraph

    For Each para In ActiveDocument.Paragraphs
        If Len(para.Range.Text) = 1 Then
            'only the paragraph mark, so..
            para.Range.Delete
        End If
    Next para
End Sub

But the problem with that code is that it removes all blank lines not only at TOP of the page but also at the center or bottom of the page.

Also if you can implement removing blank pages(Pages with no words on it) in the macro that will be fantastic. Thanks.

Answer 1

UPDATE 2: I figured out how to delete the last manual page-break in the document.

UPDATE 1: I modified the following code to delete blank pages. If a blank page consists of any or a number of blank lines (and not other text), then the original code will delete all of those since they technically start at the top of a page. Then in the second pass it will look just for Page Breaks as the only 'paragraph' on the page. If found, it will be deleted.

I think the following may solve the issue of deleting the blanks at the top of each page. Keep in mind that Word will continue to 'redraw' the page as text is deleted. But more importantly, a paragraph can be any size which means 1, 2, or 20 'lines'.

Option Explicit

Sub RemoveBlankParas()
    Dim oDoc        As Word.Document
    Dim para        As Word.Paragraph
    Dim i           As Integer
    Dim oRng        As Range
    Dim lParas      As Long
    Dim lEnd        As Long
    Dim lDeleted    As Long

    Set oDoc = ActiveDocument
    lParas = oDoc.Paragraphs.Count          ' Total paragraph count
    'Debug.Print "Total paragraph Count: " & lParas

    ' Loop thru each page
    i = 0       ' Reset starting page - if I'm testing
    Do
        ' Select one page
        i = i + 1
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        Set oRng = Selection.Range
        oRng.End = Selection.Bookmarks("\Page").Range.End
        oRng.Select

        Debug.Print "Range Count: " & oRng.Paragraphs.Count        ' Paragraphs in this page range
        lEnd = lEnd + oRng.Paragraphs.Count                         ' Keep track of how many processed

        For Each para In oRng.Paragraphs
            'Debug.Print "Par Len:" & vbTab & Len(para.Range.Text) & " | " & Left(para.Range.Text, Len(para.Range.Text) - 1)
            If Len(para.Range.Text) = 1 Then
                para.Range.Delete
                lDeleted = lDeleted + 1
            Else        ' If not blank, then delete o more in this page!
                Exit For
            End If
        Next para

        ' Calc how many paragraphs processed
        If lDeleted + lEnd >= lParas Then       ' If more that we started with, let's call it a day!
            Exit Do
        End If
    Loop

    ' You can add code to loop thru each page and if only one paagraph, ...
    ''' Check if 'empty' page

    ' Get latest count...
    lParas = oDoc.Paragraphs.Count          ' Total paragraph count

    lDeleted = 0        ' reset stuff - in case
    lEnd = 0
    i = 0
    Do
        i = i + 1
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        Set oRng = Selection.Range
        oRng.End = Selection.Bookmarks("\Page").Range.End
        oRng.Select

        Debug.Print "Range Count: " & oRng.Paragraphs.Count        ' Paragraphs in this page range
        lEnd = lEnd + oRng.Paragraphs.Count
        If oRng.Paragraphs.Count = 1 Then
            If oRng.Paragraphs(1).Range.Text = Chr(12) & Chr(13) Then
                oRng.Paragraphs(1).Range.Delete
                lDeleted = lDeleted + 1
                i = i - 1
            'ElseIf Len(oRng.Paragraphs(1).Range.Text) = 1 Then
            '    oRng.Paragraphs(1).Range.Delete
            '    lDeleted = lDeleted + 1
            '    i = i - 1
            End If
        End If
        If lEnd >= lParas Then
            Exit Do
        End If
    Loop

    ' Finally!!!  Deal with the lingering final page-break!
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=999      ' Go to Last Page.
    Set oRng = Selection.Range                                              ' Select the end..
    oRng.MoveStart wdCharacter, -3                                          ' Backup 3 characters
    If Left(oRng.Text, 2) = Chr(13) & Chr(12) Then                          ' Should be 13+12
        oRng.Text = ""                                                      ' Remove that thingy!
    End If

    Set para = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub