Quote:
Originally Posted by jc491
I ran the
SplitMergedDocument()
it gave this error 4605
no text selected
Set Rng = .Range
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
'Contract the range to exclude the Section break
.MoveEnd wdCharacter, -1
' Copy the range
.Copy
|
That suggests you're trying to run the code against an empty document.
Quote:
Originally Posted by jc491
So I could
Insert section breaks before the headings -
Use macro to split by section
Rename the Files with the first paragraph?
|
The code I posted assumes the Section breaks already exist. While you could insert the Section breaks or the code could be modified to do that itself, perhaps a better way is:
Code:
Sub SplitDocByHeading1()
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, i As Long, Doc As Document
Const StrNoChr As String = """*./\:?|"
With ActiveDocument
StrTmplt = .AttachedTemplate.FullName
StrPath = .Path & "\"
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = wdStyleHeading1
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Duplicate
StrFlNm = Split(Rng.Paragraphs(1).Range.Text, vbCr)(0)
For i = 1 To Len(StrNoChr)
StrFlNm = Replace(StrFlNm, Mid(StrNoChr, i, 1), "_")
Next
StrFlNm = StrFlNm & ".docx"
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
With Doc
.Range.FormattedText = Rng.FormattedText
.SaveAs2 FileName:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub