Question : Split word document and save based on tags

Hi,
Im currently researching how to split a word document into multiple files based on tags through the document.

The tag world be something like <FILENAME:doc-name>

The program would need to split each section into a seperate document and save it using the filename in the tag.

If any one has any suggestions on the best way to do this please let me know.

Ive found a few resources on the web but nothing definitive yet.

Answer : Split word document and save based on tags

The code below is a VBA code that would perform what you asked for. It will need to be saved as a macro in the document to be saved. The output file will be in the same path as the active document, indicated by the doc name inside the tag.

Here is where I find the resource to do it:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=140

Hope this helps!
sew

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:



Sub SplitDocs()
    Dim TotalLines      As Long
    Dim x               As Long
    Dim Groups()        As Long
    Dim Counter         As Long
    Dim y               As Long
    Dim FilePath        As String
    Dim FileName()      As String
     
    FilePath = ActiveDocument.Path
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
    Do
        TotalLines = Selection.Range.Information(wdFirstCharacterLineNumber)
        Selection.MoveDown Unit:=wdLine, Count:=1
    Loop While TotalLines <> Selection.Range.Information(wdFirstCharacterLineNumber)
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
    For x = 1 To TotalLines
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        Dim intStartPos, intEndPos
        intStartPos = InStr(Selection.Text, "<FILENAME:")
        intEndPos = InStr(Selection.Text, ">")
        If intStartPos > 0 Then
            Counter = Counter + 1
            ReDim Preserve Groups(1 To Counter)
            ReDim Preserve FileName(1 To Counter)
            Groups(Counter) = x
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            FileName(Counter) = Mid(Selection.Text, intStartPos + 10, intEndPos - (intStartPos + 10))
            Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
        End If
        Selection.HomeKey Unit:=wdLine
        Selection.MoveDown Unit:=wdLine, Count:=1
    Next
    Counter = Counter + 1
    ReDim Preserve Groups(1 To Counter)
    Groups(Counter) = TotalLines
     
    For x = 1 To UBound(Groups) - 1
        y = Groups(x + 1) - Groups(x)
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=Groups(x)
        Selection.MoveDown Unit:=wdLine, Count:=y, Extend:=wdExtend
        Selection.Copy
        Documents.Add
        Selection.Paste
        ActiveDocument.SaveAs FilePath & "\" & FileName(x) & ".doc"
        ActiveDocument.Close
    Next x
     
End Sub