didijaba
Well-known Member
- Joined
- Nov 26, 2006
- Messages
- 511
Hello, I have this code and it works fine, but there is one thing. It saves split files into My documents and not in folder where original file is. Pls advise, I'm not that good with Word VBA.
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
.
