Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 05-05-2014, 11:03 PM
didijaba didijaba is offline Split file y Heading1, saves in My documents Windows 8 Split file y Heading1, saves in My documents Office 2010 32bit
Novice
Split file y Heading1, saves in My documents
 
Join Date: May 2014
Posts: 5
didijaba is on a distinguished road
Default 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
Reply With Quote
  #2  
Old 05-06-2014, 12:49 AM
macropod's Avatar
macropod macropod is offline Split file y Heading1, saves in My documents Windows 7 32bit Split file y Heading1, saves in My documents Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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]
Reply With Quote
  #3  
Old 05-06-2014, 01:41 AM
macropod's Avatar
macropod macropod is offline Split file y Heading1, saves in My documents Windows 7 32bit Split file y Heading1, saves in My documents Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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]
Reply With Quote
  #4  
Old 05-06-2014, 05:35 AM
didijaba didijaba is offline Split file y Heading1, saves in My documents Windows 8 Split file y Heading1, saves in My documents Office 2010 32bit
Novice
Split file y Heading1, saves in My documents
 
Join Date: May 2014
Posts: 5
didijaba is on a distinguished road
Default

Thanks, works A+
Reply With Quote
Reply

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 file y Heading1, saves in My documents Split multi-page mail merge document, then name file from letter info. BriMan83 Mail Merge 1 04-24-2013 11:35 PM
Split file y Heading1, saves in My documents 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

Other Forums: Access Forums

All times are GMT -7. The time now is 10:33 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft