To: Shadowfax,
The following should be a start:
Sub SectionsToNewDocs()
Dim sFilePath As String
Dim sFileName As String
Dim nSections As Long
Dim nIndex As Long
Dim actDoc As Document
Dim newDoc As Document
Dim oRange As Range
Set actDoc = ActiveDocument
sFileName = actDoc.Name
sFilePath = actDoc.Path
If sFilePath = "" Then
MsgBox "This document does not have an active path." & Chr(13) _
& "Please save this document and try again."
Exit Sub
End If
nSections = actDoc.Sections.Count
For nIndex = 1 To nSections
Set oRange = actDoc.Sections(nIndex).Range
oRange.Copy
Set newDoc = Documents.Add
newDoc.Range.Paste
sNewFileName = UniqueFileName(sFilePath, sFileName, "")
newDoc.SaveAs FileName:=sNewFileName
newDoc.Close
Next nIndex
End Sub
'****
'*
'* UniqueFileName
'*
'* This function creates a unique name for a document based on three parts:
'* (1) the name of the active document from which this macro was ran;
'* (2) a suffix string;
'* (3) and a two digit number starting with "01"; it also tests to see if
'* such a document exists, if so, it increments the number and tries again.
'*
'****
Function UniqueFileName(ByVal sFilePath As String, _
ByVal sFileName As String, _
ByVal sSuffix As String) As String
Dim sNum As String
Dim sNewFileName As String
Dim nNumber As Long
Dim nPos As Long
nPos = InStrRev(sFileName, ".")
If nPos > 0 Then
sFileName = Left(sFileName, nPos - 1)
End If
Do
nNumber = nNumber + 1
sNum = CStr(nNumber)
If Len(sNum) = 1 Then
sNum = "0" & sNum
End If
sNewFileName = sFilePath & Application.PathSeparator _
& sFileName & "_" & sSuffix & sNum & ".Doc"
Loop While (Dir(sNewFileName) <> "" And nNumber < 1000)
UniqueFileName = sNewFileName
End Function
Steven Craig Miller
P.S. Is "Shadowfax" a name taken from the music group of same name, or the
name of Gandalf's horse?
