#1
|
|||
|
|||
Split file y Heading1, saves in My documents
HEllo, I have code that works fine, but it saves split files to My documents and not to folder where original file that started macro is. Help me to solve this, pls. Code:
Sub ParseFileByHeading() Dim aDoc As Document Dim bDoc As Document Dim Rng As Range Dim Rng1 As Range Dim Rng2 As Range Dim Counter As Long Dim Ans$ Call InsertAfterMethod Ans$ = InputBox("Enter Filename", "Incremental number added") If Ans$ <> "" Then Set aDoc = ActiveDocument Set Rng1 = aDoc.Range Set Rng2 = Rng1.Duplicate Do With Rng1.Find .ClearFormatting .MatchWildcards = False .Forward = True .Format = True .Style = "Heading 1" .Execute End With If Rng1.Find.Found Then Counter = Counter + 1 Rng2.Start = Rng1.End + 1 With Rng2.Find .ClearFormatting .MatchWildcards = False .Forward = True .Format = True .Style = "Heading 1" .Execute End With If Rng2.Find.Found Then Rng2.Select Rng2.Collapse wdCollapseEnd Rng2.MoveEnd wdParagraph, -1 Set Rng = aDoc.Range(Rng1.Start, Rng2.End) Set bDoc = Documents.Add bDoc.Content.FormattedText = Rng bDoc.SaveAs Ans$ & Counter, wdFormatDocument bDoc.Close Else 'This collects from the last Heading 1 'to the end of the document. If Rng2.End < aDoc.Range.End Then Set bDoc = Documents.Add Rng2.Collapse wdCollapseEnd Rng2.MoveEnd wdParagraph, -2 Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End) bDoc.Content.FormattedText = Rng Call FindReplaceAlmostAnywhere bDoc.SaveAs Ans$ & Counter, wdFormatDocument bDoc.Close End If End If End If Loop Until Not Rng1.Find.Found Call FindReplaceAlmostAnywhere 'This is closing End If from Ans$ End If End Sub Sub InsertAfterMethod() Dim MyText As String Dim MyRange As Object Set MyRange = ActiveDocument.Range MyText = "<Replace this with your text>" ' Selection Example: Selection.EndKey Unit:=wdStory Selection.InsertAfter (MyText) Selection.Style = ActiveDocument.Styles("Heading 1") ' Range Example: ' (Inserts text at the current position of the insertion point.) 'MyRange.Collapse 'MyRange.InsertAfter (MyText) End Sub Public Sub FindReplaceAlmostAnywhere() Dim rngStory As Word.Range Dim lngJunk As Long Dim MyText As String MyText = "<Replace this with your text>" 'Fix the skipped blank Header/Footer problem as provided by Peter Hewett lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType 'Iterate through all story types in the current document For Each rngStory In ActiveDocument.StoryRanges 'Iterate through all linked stories Do With rngStory.Find .Text = "<Replace this with your text>" .Replacement.Text = "" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Get next linked story (if any) Set rngStory = rngStory.NextStoryRange Loop Until rngStory Is Nothing Next End Sub Last edited by macropod; 05-06-2014 at 12:45 AM. Reason: Added code tags & formatting |
#2
|
||||
|
||||
Change:
bDoc.SaveAs Ans$ & Counter, wdFormatDocument to: bDoc.SaveAs aDoc.Path & "\" & Ans$ & Counter, wdFormatDocument PS: When posting code, please use the Code tags - not the Quote tags.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
Cross-posted at: http://www.mrexcel.com/forum/general...headings1.html
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
Thanks, works A+
|
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to split .pst file | annabrown8812 | Outlook | 1 | 10-03-2013 04:27 AM |
Split multi-page mail merge document, then name file from letter info. | BriMan83 | Mail Merge | 1 | 04-24-2013 11:35 PM |
reference previous heading1 | fehenry | Word | 5 | 04-20-2012 01:54 AM |
Heading1 does not convert to Kop1 | boesh | Word | 8 | 07-02-2010 05:13 AM |
Auto-File Naming/ Default Directory Saves | sgill32 | Word | 2 | 11-06-2008 02:12 PM |