1.                                   Sub SplitMergeLetterAuto()
2.                                   Dim sName As String
3.                                   Dim docName As String
4.                                   Dim Letters As String
5.                                   Dim Counter As Long
6.                                   Dim oDoc As Document
7.                                   Dim oNewDoc As Document
8.                                   Set oDoc = ActiveDocument
9.                                   oDoc.Save
10.                               
11.                               Selection.EndKey Unit:=wdStory
12.                               Letters = Selection.Information(wdActiveEndSectionNumber)
13.                               Selection.HomeKey Unit:=wdStory
14.                               Counter = 1
15.                               While Counter < Letters
16.                               Application.ScreenUpdating = False
17.                               With Selection
18.                               
19.                               .HomeKey Unit:=wdStory
20.                               .EndKey Unit:=wdLine, Extend:=wdExtend
21.                               .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
22.                               
23.                               End With
24.                               sName = Selection
25.                               docName = "C:\07-08 Scorecard Data\" & sName & ".doc"
26.                               
27.                               oDoc.Sections.First.Range.Cut
28.                               Set oNewDoc = Documents.Add
29.                               Selection.WholeStory
30.                               With Selection
31.                               .PasteAndFormat wdFormatOriginalFormatting
32.                               .HomeKey Unit:=wdStory
33.                               End With
34.                               oNewDoc.SaveAs FileName:=docName, _
35.                               FileFormat:=wdFormatDocument, _
36.                               AddToRecentFiles:=False
37.                               ActiveWindow.Close
38.                               Counter = Counter + 1
39.                               Application.ScreenUpdating = True
40.                               Wend
41.                                End Sub