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
|