Add a prefix to a document using a Inputbox

[gentle]

My macro Splits my document into many documents my using the heading1.

I have to end the document with a word at the end that I also change to a heading1. So that it Completes the macro.

I would like to be able to add the BOOK name in the box and not in the macro every time I want to change the name. (picture 1 Attached)

I know this part makes the box


ans$ = InputBox("Enter Filename", "", "")
If ans$ <> "" Then


But currently I have to change it here to add it to my doc.

brtf.SaveAs "C:\Users\Coconut\Desktop\New folder\" & "BOOK" & "-" & Format(Counter, "00") & " - " & Left(ans$, Len(ans$) - 1) & ".rtf", wdFormatDocument


My Documents are saved as follows :

BOOK-01 - Plan for Man.rtf
BOOK-02 - I. Importance of the .rtf
BOOK-03 - II. The Simplicity of the .rtf
BOOK-04 - III. Definition of the Term.rtf

What do I change to be able just add the BOOK name in the box .


Here it is:


Sub TESTER()

Dim artf As Document
Dim brtf As Document
Dim Rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim ans$

ans$ = InputBox("Enter Filename", "", "")
If ans$ <> "" Then

Set artf = ActiveDocument
Set Rng1 = artf.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
ans$ = Rng1.Text
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 = artf.Range(Rng1.Start, Rng2.End)
Set brtf = Documents.Add
brtf.Content.FormattedText = Rng

'If ans$ <> "" Then
brtf.SaveAs "C:\Users\Coconut\Desktop\New folder\" & "BOOK" & "-" & Format(Counter, "00") & " - " & Left(ans$, Len(ans$) - 1) & ".rtf", wdFormatDocument
'brtf.SaveAs Ans$ & Counter, wdFormatDocument
brtf.Close


Else
'This collects from the last Heading 1
'to the end of the document.
If Rng2.End < artf.Range.End Then
Set brtf = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = artf.Range(Rng2.Start, artf.Range.End)
brtf.Content.FormattedText = Rng

'If ans$ <> "" Then
brtf.SaveAs "C:\Users\Coconut\Desktop\New folder\" & "BOOK" & "-" & Format(Counter, "00") & " - " & Left(ans$, Len(ans$) - 1) & ".rtf", wdFormatDocument
'brtf.SaveAs Ans$ & Counter, wdFormatDocument
brtf.Close
End If
End If
End If


Loop Until Not Rng1.Find.Found

'This is closing End If from Ans$

End If
End Sub



Thank you in advance.

:hi:: pray2::help

[Tinbendr]

The code already uses Ans$ as the Heading string in the part of the filename, so you'll need another variable. I chose BookName$.

I also don't understand this part.
Left(ans$, Len(ans$) - 1)

Are you trying to remove a trailing space, perhaps?

If so, then, use the Trim Function.
brtf.SaveAs "C:\Users\Coconut\Desktop\New folder\" & BookName$ _
& "-" & Format(Counter, "00") & " - " & _
Trim(ans$) & ".rtf", wdFormatDocument
Sub TESTER()

Dim artf As Document
Dim brtf As Document
Dim Rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim BookName$

BookName$ = InputBox("Enter Filename", "", "")
If BookName$ <> "" Then
Set artf = ActiveDocument
Set Rng1 = artf.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
ans$ = Rng1.Text
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 = artf.Range(Rng1.Start, Rng2.End)
Set brtf = Documents.Add
brtf.Content.FormattedText = Rng

'If ans$ <> "" Then
brtf.SaveAs "C:\Users\Coconut\Desktop\New folder\" & BookName$ _
& "-" & Format(Counter, "00") & " - " & _
Left(ans$, Len(ans$) - 1) & ".rtf", wdFormatDocument
'brtf.SaveAs Ans$ & Counter, wdFormatDocument
brtf.Close


Else
'This collects from the last Heading 1
'to the end of the document.
If Rng2.End < artf.Range.End Then
Set brtf = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = artf.Range(Rng2.Start, artf.Range.End)
brtf.Content.FormattedText = Rng

'If ans$ <> "" Then
brtf.SaveAs "C:\Users\Coconut\Desktop\New folder\" & BookName$ _
& "-" & Format(Counter, "00") & " - " & _
Left(ans$, Len(ans$) - 1) & ".rtf", wdFormatDocument
'brtf.SaveAs Ans$ & Counter, wdFormatDocument
brtf.Close
End If
End If
End If


Loop Until Not Rng1.Find.Found

'This is closing End If from Ans$

End If
End Sub


David

[gentle]

David



I also don't understand this part.
Left(ans$, Len(ans$) - 1)

Are you trying to remove a trailing space, perhaps?

I am not sure about that.

But the macro lets me:

What ever I choose as a heading1 in my main document it then splits it in to smaller documents.

The heading1 then becomes my file names as well as keeping the documents in number order.

Now with your help I am even able to add the book it came from.


Thank you so much

IT WORKS :bow: