#1
|
|||
|
|||
Small tweak to a macro
Can anyone help at all with a small tweak to this macro ?
The macro creates a new Word file using the text within a range defined by Heading 1 text. So range = text between 1st Heading 1 and 2nd Heading 1. Each file is saved with the name of Heading 1. However I`d like each file to be titled as Heading 1&" - "Heading 2. Can anyone with the time and expertise kindly help ? Code:
Sub SplitDoc() ' Disable screen updating to improve performance Application.ScreenUpdating = False ' Declare variables Dim Rng As Range ' Represents a range within the document Dim DocSrc As Document ' Represents the source (original) document Dim DocTgt As Document ' Represents the target (newly created) document Dim i As Long ' Counter variable for loops Dim StrTxt As String ' Stores the title of the section Const StrNoChr As String = """*./\:?|" ' List of illegal characters in filenames ' Set the source document as the currently active document Set DocSrc = ActiveDocument ' Configure find settings for heading style 1 With DocSrc.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Format = True .Forward = True .Text = "" .Style = wdStyleHeading1 ' Search for heading style 1 .Replacement.Text = "" .Wrap = wdFindStop .Execute End With ' Loop through the document and split based on heading style 1 Do While .Find.Found ' Set the range for the current heading Set Rng = .Paragraphs(1).Range ' Move to the corresponding bookmark in the heading Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel") ' Create a new target document based on the source document's template Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName) ' Configure target document With DocTgt ' Copy the formatted text from the source heading to the target document .Range.FormattedText = Rng.FormattedText ' Extract the text of the first paragraph (title) from the target document StrTxt = Split(.Paragraphs.First.Range.Text, vbCr)(0) ' Strip out illegal characters from the title For i = 1 To Len(StrNoChr) StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_") Next ' Save the target document with a modified filename and specific format .SaveAs2 FileName:=DocSrc.Path & "\" & StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False ' Close the target document without saving changes .Close False End With ' Move the starting point of the find operation to the end of the current heading .Start = Rng.End ' Perform the find operation again .Find.Execute Loop End With ' Clean up and restore screen updating Set Rng = Nothing Set DocSrc = Nothing Set DocTgt = Nothing Application.ScreenUpdating = True End Sub |
#2
|
|||
|
|||
Hi, if I corectly understand your objective, the following may work:
Code:
Sub SplitDoc_() 'Disable screen updating to improve performance Application.ScreenUpdating = False 'Declare variables Dim Rng As range ' Represents a range within the document Dim Rng1 ' Represents Heading1 Dim DocSrc As Document ' Represents the source (original) document Dim DocTgt As Document ' Represents the target (newly created) document Dim i As Long ' Counter variable for loops Dim StrTxt As String ' Stores the title of the section Const StrNoChr As String = """*./\:?|" ' List of illegal characters in filenames 'Set the source document as the currently active document Set DocSrc = ActiveDocument 'Configure find settings for heading style 1 With DocSrc.range With .Find .ClearFormatting .Replacement.ClearFormatting .Format = True .Forward = True .text = "" .Style = wdStyleHeading1 ' Search for heading style 1 .Replacement.text = "" .Wrap = wdFindStop .Execute End With 'Set the range for & remember Heading1: If .Find.found Then Set Rng1 = .Paragraphs(1).range Rng1.End = Rng1.End - 1 'Loop through the document and split based on heading style 1 Do While .Find.found 'Set the range for the current heading Set Rng = .Paragraphs(1).range 'Move to the corresponding bookmark in the heading Set Rng = Rng.GoTo(What:=wdGoToBookmark, name:="\HeadingLevel") 'Create a new target document based on the source document's template Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName) 'Configure target document With DocTgt 'Copy the formatted text from the source heading to the target document .range.FormattedText = Rng.FormattedText 'Extract the text of the first paragraph (title) from the target document StrTxt = Split(.Paragraphs.First.range.text, vbCr)(0) 'Strip out illegal characters from the title For i = 1 To Len(StrNoChr) StrTxt = Replace(StrTxt, Mid(StrNoChr, i, 1), "_") Next 'Save the target document with a modified filename and specific format .SaveAs2 fileName:=DocSrc.path & "\" & Rng1 & " - " & StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False 'Close the target document without saving changes .Close False End With 'Move the starting point of the find operation to the end of the current heading .Start = Rng.End 'Perform the find operation again .Find.Execute Loop End With 'Clean up and restore screen updating Set Rng = Nothing Set DocSrc = Nothing Set DocTgt = Nothing Application.ScreenUpdating = True End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro to change Small Caps to Lower Case | carrollmt | Word VBA | 5 | 03-07-2023 09:19 AM |
Can one tweak the format of automatically created pages? | mmo | OneNote | 0 | 11-07-2016 04:31 PM |
Tweak Macro to Save Each Page of Word Document as Separate PDF or Doc File? | Hewg74 | Word VBA | 3 | 08-22-2016 05:20 PM |
Help tweak the Macro | streetcat | Word VBA | 3 | 01-27-2015 05:44 AM |
New to Word 2010 and I need to tweak it for printing | Bobosmite | Word | 1 | 07-01-2010 11:31 AM |