Word file split by Heading1, save location help needed

[didijaba]

Hello, I have this code and it workes fine but it saves split files to My documents and not in folder where original file is located. I am not good with VBA Word so pls advise. Thanks

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.EndKey Unit:=wdStory
  Selection.InsertAfter (MyText)
  Selection.Style = ActiveDocument.Styles("Heading 1")
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

 

[didijaba]

S o s

 

[didijaba]

this part saved it, thanks

bDoc.SaveAs aDoc.Path & "\" & Ans$ & Counter, wdFormatDocument