Deleting blank pages in large documents - vba

Question

We use SAS to output to rtf files then compile a load together, creating very large documents in most cases. But when compiling these outputs into one single document blank pages are sometimes created and we need to go through searching for and deleting these pages.
The code I have so far seems to work for the most part, but I am coming across a memory error on some occasions and wondering if anyone has suggestions to improve the code?
The following is the start of the code which is where I am getting the memory error on some occasions:
Sub BlankPage()
Application.ScreenUpdating = False
Application.Options.Pagination = False
Dim i As Long, Rng As Range, Blank As Integer, Page() As Long
With ActiveDocument
Blank = 0
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
If Len(Rng) < 3 Then
Blank = Blank + 1
ReDim Preserve Page(Blank)
If Blank = 1 Then
Page(Blank) = Rng.Information(wdActiveEndAdjustedPageNumber)
Else
Page(Blank) = ((Rng.Information(wdActiveEndAdjustedPageNumber) - Blank) + 1)
End If
End If
Next i
Application.Options.Pagination = True
Application.ScreenUpdating = True
If Blank = 1 Then
MsgBox "Found " & Blank & " page to check"
Else
MsgBox "Found " & Blank & " pages to check"
End If
Dim j As Long, StrPages As String, intResponse As Integer, No As Long
No = 0
If Blank > 0 Then
For j = 1 To Blank
Set Rng = .GoTo(What:=wdGoToPage, Name:=((Page(j) + No))
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
Selection.GoTo(What:=wdGoToPage, Which:=wdGoToNext, Name:=(Page(j) + No))
intResponse = MsgBox("Are you sure you want to delete this page?", vbYesNo)
If intResponse = vbYes Then
StrPages = StrPages & " " & Rng.Information(wdActiveEndAdjustedPageNumber)
Rng.Delete
Else
No = No + 1
End If
Next j
End If
End With

Answer 1

This is somewhat messy and more of a hack because I don't have your data (and therefore I am not sure what Len(rng) < 3 is about, but you can add another loop to declare your array size one time, instead of doing it for each loop.
This can either result in a performance loss or performance gain (I would think gain since you are not constantly using ReDim Preserve).
Sub BlankPage()
Application.ScreenUpdating = False
Application.Options.Pagination = False
Dim i As Long, Rng As Range, Blank As Integer, Page() As Long
With ActiveDocument
Blank = 0
'Get the array size ONE time only
For i = 1 To .ComputeStatistics(wdStatisticPages)
If Len(Rng) < 3 Then Blank = Blank + 1
Next
ReDim Page(Blank) '< -- You ReDim only once -- <
Blank = 0
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
If Len(Rng) < 3 Then
blank = blank + 1
If Blank = 1 Then '< -- remove the ReDim preserve -- <
Page(Blank) = Rng.Information(wdActiveEndAdjustedPageNumber)
Else
Page(Blank) = ((Rng.Information(wdActiveEndAdjustedPageNumber) - Blank) + 1)
End If
End If
Next i
Application.Options.Pagination = True
Application.ScreenUpdating = True