Solved: Split Word Doc and Rename

[BlueTick]

:banghead:
Im using this code found in KBase. How can I name the new doc with information from the current active page.

I have a 40+ page word doc that when split each new doc could be assigned a file name from the first five digites of the 7th line of the doc.

I have tried Line Input but it dosent work.

Macro to split file

Option Explicit 'This goes in the Declarations section of your code module.
'Hopefully it is already there because you have ticked the 'Require Variable Declaration' _
checkbox. (Tools/Options, Editor tab.)
Sub SplitIntoPages()
Dim docMultiple As Document
Dim docSingle As Document
Dim rngPage As Range
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
Dim txtUnit As String

Application.ScreenUpdating = False 'Makes the code run faster and reduces screen _
flicker a bit.
Set docMultiple = ActiveDocument 'Work on the active document _
(the one currently containing the Selection)
Set rngPage = docMultiple.Range 'instantiate the range object
iCurrentPage = 1
'get the document's page count
iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Then
rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)
Else
'Find the beginning of the next page
'Must use the Selection object. The Range.Goto method will not work on a page
Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
'Set the end of the range to the point between the pages
rngPage.End = Selection.Start
End If
rngPage.Copy 'copy the page into the Windows clipboard
Set docSingle = Documents.Add 'create a new document
docSingle.Range.Paste 'paste the clipboard contents to the new document
'remove any manual page break to prevent a second blank
docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
'build a new sequentially-numbered file name based on the original multi-paged file name and path
strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")

Call Macro2 ' macro to format new documents

docSingle.SaveAs strNewFileName 'save the new single-paged document

Call LoadCurDoc1(strNewFileName) 'function to get first 5 digets of the 7th line of current doc (dosent work to embarrased to post)

iCurrentPage = iCurrentPage + 1 'move to the next page
docSingle.Close 'close the new document
rngPage.Collapse wdCollapseEnd 'go to the next page
Loop 'go to the top of the do loop
Application.ScreenUpdating = True 'restore the screen updating
'Destroy the objects.
'(Not really necessary. VB does it automatically when the objects go out _
of scope, but they like it in this forum.)
Set docMultiple = Nothing
Set docSingle = Nothing
Set rngPage = Nothing
End Sub


Macro to format new doc

Sub Macro2()
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = InchesToPoints(0.5)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(11)
.PageHeight = InchesToPoints(8.5)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub

[mdmackillop]

Amend this line
docSingle.SaveAs MyPath & fName & ".doc" 'save the new single-paged document to use this function
Function fName()
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=7
With Selection
.MoveEnd unit:=wdCharacter, Count:=5
.Select
End With
fName = "\" & Selection
End Function

[BlueTick]

:rotlaugh:

There may be a better way but I solved it:

Call the function

strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & SortParagraph & "_" & Right$("000" & iCurrentPage, 4) & ".doc")

Find Paragraph

Function SortParagraph()
Dim r As Word.Range
Dim oPara As Word.Paragraph
Dim strUnit As String
Dim lngLineCount As Long
lngLineCount = 0
For Each oPara In ActiveDocument.Paragraphs()
lngLineCount = lngLineCount + 1
If lngLineCount = 8 Then
Set r = oPara.Range
Select Case r.ListFormat.ListType
Case wdListNoNumbering
strUnit = Left(r.Text, 5)
End Select
Set r = Nothing
Else
End If
Next
SortParagraph = strUnit
End Function


The code for the Paragraph Function I found in this forum. Modified it with a counter to stop at the line.

Thanks

[BlueTick]

Thanks mdmackillop, I'll try you version also.

[Dave]

Just a suggestion to speed things up. Add..

Set r = Nothing
Exit For


Otherwise you loop through the rest of the doc. HTH. Dave

[BlueTick]

Thanks Dave.

[fumei]

Hmmm. You are processing through every paragraph just to get the string? This is excessive.

At the very least you should escape out of the For Each loop (with a Exit For instruction) once you have found your string. Otherwise, sure you got the string, but the code will continue on processing every other paragraph.

Further, you ARE counting by paragraph, not line. For Each oPara In ActiveDocument.Paragraphs()
lngLineCount = lngLineCount + 1
If lngLineCount = 8 Then

If this is the case, why bother going through all of that?? You can access the paragraph directly with
ActiveDocument.Paragraphs(7)

In fact, if they are paragraphs, then the first 5 letters of the 7th paragraph can be returned with:strUnit = Left(ActiveDocument.Paragraphs(7).Range.Text, 5)

Done.

If you DO need to test for ListFormat (although I can not see why, PLUS your Select Case has no alternative logic so is rather pointless), then you can:If ActiveDocument.Paragraphs(7).Range.ListFormat.ListType _
= wdListNoNumbering Then
strUnit = Left(ActiveDocument.Paragraphs(7).Range.Text, 5)
End If

[fumei]

I would also add that you can get whatever string you want without using Selection. There is most likely no need to make a Selection of the text. After all, you don't really want to select it. You just want the string, right?

You want the string to use for the filename. You don't want to Select it, you just want to know what the string is. Actually, you don't even care about that, you want to be able to USE it. You can use it without selecting it, or running through all the paragraphs, or even knowing what is the actual text.

It seems to me that you do not need to make or use a Range object (for getting the string, that is); you do not need to loop through all the paragraphs, and you do not need any extra Function.

[BlueTick]

fumei,

Thanks for the additional assistance. The loop was due to the line number sometimes changes from the original doc. This is because I cut and paste from two different file types .txt and .lis .

But that?s another issue entirely. Once again thanks.


How do I mark this as solved? I have enough to guide me in the right direction. The only other issue is converting/Importing to word.

[fumei]

The loop was due to the line number sometimes changes from the original doc. Not sure what relevance that is if you are using paragraphs as objects. The line number is totally irrelevant if using paragraph objects.

But whatever. Glad it is working for you. You can mark it as Solved using the Thread Tools at the top of the thread.