extra empty pages added when macro executes

[RaineSpencer]

I am running a nifty word macro, found on this board. If the source merged doc is 1 page per person, the macro adds 1 blank page to each split doc. If the source merged doc is 2 pages per person, the macro adds 2 blank pages at the end of each split doc, and so on. I can't see why it is adding the blank pages. Can anybody see the problem???

TIA --
Raine
******************************************************

Sub SplitApart()
Dim x As Long
Dim sections As Long
Dim doc As Document

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set doc = ActiveDocument
sections = doc.sections.Count
For x = sections - 1 To 1 Step -1
doc.sections(x).Range.Copy
Documents.Add

ActiveDocument.Range.Paste
ActiveDocument.SaveAs (doc.Path & "\" & x & ".doc")
Selection.GoTo What:=wdGoToPage, Which:=wdGoToLast
Selection.Delete
ActiveDocument.Close False
Next x

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[RaineSpencer]

Got it resolved. The macro adds a section break at the end of each document. A little code change to remove the additional breaks takes care of the issue. I also added code to look for the document name at the end of each document [contains a merge field unique to each person merged] and save with that unique, identifiable name.

Sub AllSectionsToSubDoc()

Dim x As Long
Dim sections As Long
Dim doc As Document
Dim strBookMark As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set doc = ActiveDocument
sections = doc.sections.Count
For x = sections - 1 To 1 Step -1
doc.sections(x).Range.Copy
Documents.Add
ActiveDocument.Range.Paste

Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
With Selection.Find
.Text = "U:\\data*"
.Execute MatchWildcards:=True, Forward:=True, Wrap:=wdFindStop
If .Found = True Then Selection.Extend
Selection.Extend
ActiveDocument.SaveAs (Selection.Text)

End With
With ActiveDocument.Range.Find
.ClearFormatting
.Text = "^b"
With .Replacement
.ClearFormatting
.Text = ""
End With
.Execute Replace:=wdReplaceAll
End With
ActiveDocument.Save

'ActiveDocument.SaveAs (Doc.Path & "\" & x & ".doc")
' End If
'End With
ActiveDocument.Close False
Next x

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub