Solved: Code not copying header and footer.

[zebradoby]

I have this code to divide the huge word file (50 pages) into 25 files of 2 pages each. I am having the following 2 issues: Can anyone please help?

1. The header and footer do not get copied to the target (25 files of 2 pages each) documents from the source document.

2. The format does not remain the same. I think the margins get altered. I want to keep exact same format as the source document.

To use code:
Open word.
Copy code
Click Run
Select a file with at least 4 pages (word file)

Let me know if anyone can help. Please see code below.



'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave

Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")

'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name

FileToOpen = wrdDoc.Name

'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"

Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var

Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
Selection.WholeStory


j = 1
Set thisdoc = Activedocument
Set r = thisdoc.Range(0, 0)
For var = 1 To thisdoc.Range _
.Information(wdNumberOfPagesInDocument) / 2
Set Thatdoc = Documents.Add


With r
.MoveEndUntil Cset:=Chr(12)
.MoveEnd Unit:=wdCharacter, Count:=1
.MoveEndUntil Cset:=Chr(12)
.Copy
End With

Selection.PasteAndFormat (wdFormatOriginalFormatting)


Thatdoc.SaveAs _
FileName:="c:\" & j & "-" & j + 1 & _
" pages.doc"
Thatdoc.Close
r.Collapse Direction:=wdCollapseEnd
r.Move Unit:=wdCharacter, Count:=1
j = j + 2
Next

Activedocument.Close savechanges:=wdDoNotSaveChanges

'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."



End If

End Sub

''' Function: FileOpenCustom


Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.


If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function

[fumei]

You are cross posting like crazy on this one. I have answered elsewhere most of your questions.

As for the header/footer issue...no, they wouldn't be copied over. It would help if you:

1. understand Word more. I have posted information on this in your threads at Tek-Tips.

2. clearly state in your posts the whole issue, and not add extra stuff.

Regarding your header/footer. If you want to do this - split up a document into multiple documents and retain format and header/footer...then, as I have posted elsewhere to you.....

Use templates.

If you have a template with those header and footer, then dump your page chunks into new documents from that template...then Voila!...it will be as you want it.

It most certainly IS possible to get your chunks, and copy over the header and footer. However, I am not going to post how to do that.

You should be dumping your chunks into documents from a template that HAS those headers and footers.

I have mentioned this about templates a number of times in your threads.

[lucas]

zebradoby,
Please read our FAQ.
Click here (http://www.excelguru.ca/node/7) for an explanation of cross-posting

You will find it hard to find help after folks find out you are cross posting without providing links...

[zebradoby]

Hi Buddy

I should have explained it clearly. thanks for your tip. Here is the issue:

1. When i use this code to divide files into 1 pagers, it copies headers and footers.

2. When i use the same code to divide the files into 2 pages, it DOES NOT copy headers and footers. That is why i needed help. I researched a lot on it the way you told me, but have not been successful as it is exact same code. And it works on 1 pager files and not on 2 pager files.

Thanks for your help. Let me know.

[zebradoby]

Hi Lucas

I am new to these forums and shall be careful in future. Thanks for letting me know. I am sure, you will give some soft leverage to new bees like me..:)

Thanks once again.

[lucas]

No problem. We appreciate you reading the explainations so that you can understand why we ask for links....cross posting in itself is not a problem

[fumei]

OK, then the issue is with the header and footer in the source file.

Can you describe what they are?

[zebradoby]

Hi Buddy

I have attached a sample test file. need help on copying headers and footers for dividing the file into 2 pagers.

1. When i use this code to divide files into 1 pagers, it copies headers and footers.

2. When i use the same code to divide the files into 2 pages, it DOES NOT copy headers and footers.

thanks once again. I owe you big time for all your efforts.

[TonyJollans]

I haven't looked at your code as there wasn'ty any in the document that I could see :) Nor have I read everything here.

However, whether or not you get headers and footers copied depends on whether or not the section break (which, in a way, contains them) is included in the copied data.

If your copy ends with a section break for other than the last section, you will get the headers and footers but you will also get an extra section as a result of the break.

If your copy ends with the last paragraph mark in the document, this doubles (trebles?) as end-of-document and section break for the last section so you will get the headers and footers.

If your copy does not include a section break of any kind you will not get the headers and footers. The number of pages copied is not relevant.

[zebradoby]

Hi tony

To use the code
Open a blank word (new) file
Alt F11
Copy and paste the code
Run
Select the word file (or any other file with heades, footers and at least 4 pages long) attached in the previous post.

The divided file has 2 pages each. But the header and footer are missing.

The code is in my previous post. But i am posting it again.

'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave

Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")

'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name

FileToOpen = wrdDoc.Name

'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"

Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var

Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
Selection.WholeStory


j = 1
Set thisdoc = Activedocument
Set r = thisdoc.Range(0, 0)
For var = 1 To thisdoc.Range _
.Information(wdNumberOfPagesInDocument) / 2
Set Thatdoc = Documents.Add


With r
.MoveEndUntil Cset:=Chr(12)
.MoveEnd Unit:=wdCharacter, Count:=1
.MoveEndUntil Cset:=Chr(12)
.Copy
End With

Selection.PasteAndFormat (wdFormatOriginalFormatting)


Thatdoc.SaveAs _
FileName:="c:\" & j & "-" & j + 1 & _
" pages.doc"
Thatdoc.Close
r.Collapse Direction:=wdCollapseEnd
r.Move Unit:=wdCharacter, Count:=1
j = j + 2
Next

Activedocument.Close savechanges:=wdDoNotSaveChanges

'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."



End If

End Sub

''' Function: FileOpenCustom


Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.


If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function

[zebradoby]

The test file was used to divide into smaller files. So, there will not be any code in the document. The code has to be posted in a blank (separate) word file and then select this test file to process. The web site wonot let me attach the file again. However, i am posting the code again.

Code:
'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave

Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")

'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name

FileToOpen = wrdDoc.Name

'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"

Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var

Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
Selection.WholeStory
j = 1
Set thisdoc = Activedocument
Set r = thisdoc.Range(0, 0)
For var = 1 To thisdoc.Range _
.Information(wdNumberOfPagesInDocument) / 2

Set Thatdoc = Documents.Add
With r
.MoveEndUntil Cset:=Chr(12)
.MoveEnd Unit:=wdCharacter, Count:=1
.MoveEndUntil Cset:=Chr(12)
.Copy
End With


Selection.PasteAndFormat (wdFormatOriginalFormatting)


Thatdoc.SaveAs _
FileName:="c:\" & j & "-" & j + 1 & _
" pages.doc"
Thatdoc.Close
r.Collapse Direction:=wdCollapseEnd
r.Move Unit:=wdCharacter, Count:=1
j = j + 2
Next

Activedocument.Close savechanges:=wdDoNotSaveChanges

'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."


End If

End Sub

''' Function: FileOpenCustom


Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.


If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function

[TonyJollans]

As I said earlier, whether or not headers and footers are copied depends on whether or not the section mark is included in the copy.

Your posted document contains three sections, each of two pages, the pages being separated by a hard page break. The code you have posted for two pages:

* starts at the beginning and looks forward up to, but not including, a Chr(12) character
* includes the Chr(12) character by going forward a character
* looks forward again, up to, but not including, the next Chr(12) character
* copies and pastes and saves the new document
* skips over the next character (the section break)
* .. and loops

Now, a Chr(12) is either a page break or a section break so you get the first page, the page break and the second page without the section break - so no headers and footers. You then skip the section break and repeat - each time not getting the headers and footers.

I don't know how you adjust the code to take single pages only so can't definitely say why that behaves differently.

What do you want to achieve? Copy sections? Or individual pages with header and footer information?

[fumei]

I posted that code in response to the stated objective. I also DID mention, and ask, for specific information on your page breaks. I asked if there were Section breaks.

You never mentioned headers and footers. If you had, then I would have taken that into consideration, as Tony is - as usual - 100% correct. It is absolutely vital to know things like Section breaks, as they hold header/footer information.

[zebradoby]

Hi Guys

Thanks for the response.

The document shall have hard page breaks as shown in the attached Test Document in the previous message. I am ok with 1 pagers. I was trying to divide the document into 2 pagers each. Thats where i am having a problem. So, when i run the code and divide and auto save the file, i want to save the header and footer in each divided file. I just want to copy 2 pages each in separate files, everything thats on those 2 pages. I hope i clarified.

Let me know.


Thanks

[zebradoby]

You have been a great help "fumei". Thanks for everything.

[TonyJollans]

I don't understand at all how you are doing it with single pages - or, in general, with any particulare number of *pages* - it is *sections* that are significant. Please post your working code for single pages and I can tell you how to adjust it for other numbers of pages.

[zebradoby]

Hi Tony

To use the code:
Open a new word file.
Copy the code
Run the code
Select the attached Test File to process.


For one pager, i use this code and this is working perfectly fine for me.


'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave

Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")

'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name

FileToOpen = wrdDoc.Name

'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"

Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim ThisDoc As Document
Dim Thatdoc As Document
Dim var

Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
Selection.WholeStory

j = 1
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range(0, 0)
For var = 1 To ThisDoc.Range _
.Information(wdNumberOfPagesInDocument) / 1
Set Thatdoc = Documents.Add
With r
.MoveEndUntil Cset:=Chr(12)
.MoveEnd Unit:=wdCharacter, Count:=1

.Copy
End With

Selection.Paste
Thatdoc.SaveAs _
FileName:="c:\" & j & "-" & j + 1 & _
" pages.doc"
Thatdoc.Close
r.Collapse Direction:=wdCollapseEnd
r.Move Unit:=wdCharacter, Count:=1
j = j + 2

Next




ActiveDocument.Close savechanges:=wdDoNotSaveChanges

'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."


End If

End Sub

''' Function: FileOpenCustom


Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.


If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = ActiveDocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function

---------------------------------------------------------------

[zebradoby]

Hi Tony
I need help to include header , footer and all the text between header and footer on the divided files. I mean copy all sections in a page.

Thanks for your help.

[TonyJollans]

That code doesn't do single pages with headers and footers from your posted document.

I'm off to bed now. I'll post back in the morning but basically you have to do more work than just copying and pasting - it may well be easiest in this case to copy the section and then delete the bits you don't want.

What exactly is the purpose of this procedure? Why do you want each page in its own document?

[zebradoby]

Hi Tony

Purpose: To divide a huge file of about 1600 pages into each individual file by loan number. The file should be saved with a name by the loan number on each page (this is not in code but want it). The file is then automatically saved into the destination given. (this is already in code). Some of the files have to divided into 2 pagers and some into 1 pagers depending on the source file. I only provided a small sample here of the file. And when the huge file is divided, it needs to save everything that is on the source file.



Summary

Things i could not figure out:

1. Copy header and footer. And everything else thats on the page between header and footer when the file is divided and saved.
2. Get the loan number on each page.
3. Save each file with a filename that contains this loan number.

I hope this clarified.

Thanks

[zebradoby]

Each page in its own document needed so that its easy to reference when needed later on, instead of going thro a 1600 page file.

[TonyJollans]

I keep asking about pages because, if you really do want pages, regardless of any other facts, then it is more complex. From what I can see you want sections, which may be single pages or may be multiple pages so unless you say otherwise that is what I will work with.

Is your document the result of a MailMerge?

[zebradoby]

Hi Tony

Yes, its a mail merge of csv, but i am not 100% sure. This is how the file was given to me. Sections is fine as we will get the same result with sections (dividing and saving page or multi pages) as well. I read abt sections last nite, so it was my ignorance abt sections until last night. I think sections will be better. So, its cool.

Hope this clarified.

Thanks

[TonyJollans]

I asked about a mail merge because it would be possible to make the mail merge produce individual documents to begin with but if you've just been given the file then you'll have to split it yourself.

A loop something like this is what you need in the middle of your posted code ...


Set thisdoc = ActiveDocument
For Each s In thisdoc.Sections
s.Range.Copy
With Documents.Add
.Range.PasteAndFormat (wdFormatOriginalFormatting)
.Sections(1).Range.Characters.Last.Delete
.SaveAs "Section" & s.Index
.Close
End With
Next



(to replace code from Selection.WholeStory down to Next)

[zebradoby]

Thanks Tony, i will try it tomorrow at work. Hopefully, it works. Thanks once again.

[zebradoby]

Hi Tony

Thanks for all your help. I have one last question:

Is it possible to read the Loan Number from each section. And Then save each divided file with that loan number? If yes, how ?


Thanks

[zebradoby]

Is it possible to read the Loan Number from each section. And Then save each divided file with that loan number? If yes, how ?


Here is my latest code:

To use code:
Copy and paste code into new word file
Run the code
Select a file with at least 4 pages.




'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave

Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")

'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name

FileToOpen = wrdDoc.Name

'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"

Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var

Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto

Set thisdoc = Activedocument
For Each s In thisdoc.Sections
s.Range.Copy
With Documents.Add
.Range.PasteAndFormat (wdFormatOriginalFormatting)
.Sections(1).Range.Characters.Last.Delete
.SaveAs _
FileName:="c:\" & "Test_" & s.Index
.Close
End With
Next

Activedocument.Close savechanges:=wdDoNotSaveChanges

'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."


End If

End Sub

''' Function: FileOpenCustom


Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.


If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function

[TonyJollans]

Try this (instead of the code I posted before).

Based on your sample document, it searches for the Loan Number. If it doesn't find it it calls the file "Loan Tempnnn" (where nnn is a unique number). If it does find it it calls it "Loan ########" (where ######## is the loan number), unless it's a duplicate in which case it calls it "Loan Dupnnn ########" (where nnn is unique and ######## is the loan number).


Set thisdoc = ActiveDocument
Dim S As Section
Dim Loan As Range
Dim TempNo As Long
Dim FileSuffix As String
Dim FilePrefix As String
FilePrefix = "C:\Users\Tony\Desktop\Loan "
For Each S In thisdoc.Sections
Set Loan = S.Range.Duplicate
If Loan.Find.Execute(FindText:="Loan Number") Then
Loan.MoveWhile " "
Loan.MoveEndUntil Chr(13)
FileSuffix = Loan.Text
Else
TempNo = TempNo + 1
FileSuffix = "Temp" & TempNo
End If
S.Range.Copy
With Documents.Add
.Range.PasteAndFormat (wdFormatOriginalFormatting)
.Sections(1).Range.Characters.Last.Delete
If Dir(FilePrefix & FileSuffix & ".doc") <> "" Then
TempNo = TempNo + 1
FileSuffix = "Dup" & TempNo & " " & FileSuffix
End If
.SaveAs FilePrefix & FileSuffix & ".doc", wdFormatDocument
.Close
End With
Next

[zebradoby]

Hi tony

You are the best...i owe you big time. Let me run the code and see if it works.

Thanks

[TonyJollans]

Just noticed - and you probably have too - that you will need to change FilePrefix to your own location. Based on your earlier code ...

FilePrefix = "C:\Loan "

[zebradoby]

Hi Tony

Yeah, I changed it to ?C:\?. Thanks.

I run this code. I get the error message ?Run time error 52 Bad File name or number?. Would you know why? And how do I fix it?

I have attached the sample test file (file name: test vacancy). It ran perfectly on the previous attached file though. I promise this is my last request.

Thanks

To use code:

Open a new word file
Copy the code
Select the attached file



Code:



'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave

Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")

'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name

FileToOpen = wrdDoc.Name

'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"

Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var

Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto

Set thisdoc = Activedocument

Dim S As Section
Dim Loan As Range
Dim TempNo As Long
Dim FileSuffix As String
Dim FilePrefix As String
FilePrefix = "C:\"
For Each S In thisdoc.Sections
Set Loan = S.Range.Duplicate
If Loan.Find.Execute(FindText:="Test Loan Number:") Then
Loan.MoveWhile " "
Loan.MoveEndUntil Chr(13)
FileSuffix = Loan.Text
Else
TempNo = TempNo + 1
FileSuffix = "Temp" & TempNo
End If
S.Range.Copy
With Documents.Add
.Range.PasteAndFormat (wdFormatOriginalFormatting)
.Sections(1).Range.Characters.Last.Delete
If Dir(FilePrefix & FileSuffix & ".doc") <> "" Then
TempNo = TempNo + 1
FileSuffix = "Dup" & TempNo & " " & FileSuffix
End If
.SaveAs FilePrefix & FileSuffix & ".doc", wdFormatDocument
.Close
End With
Next

Activedocument.Close savechanges:=wdDoNotSaveChanges

'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."


End If

End Sub

''' Function: FileOpenCustom


Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.


If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function

[TonyJollans]

The reason is that the Loan Number is in a different format in this file.

In the first file it was Loan Number(colon)(spaces)#########

In this file it is Loan Number(colon)(space)(tab)########

The tab character has, thus been included in the file name and the Dir function doesn't like it.

Change:
Loan.MoveWhile " "
To
Loan.MoveWhile " " & vbTab
and it should be alright.

[zebradoby]

Hi Tony

Thanks for all your help. Let me know if i can do anything for you. I owe you big time. I was able to make few changes and run the code the way i wanted it. What is your email address? I see you live in UK. Any trips planned to US?

Thanks once again.

[TonyJollans]

> Any trips planned to US?

I hope to make the MVP Summit in Seattle again next year.

[zebradoby]

test

[zebradoby]

test

[zebradoby]

test

[zebradoby]

test

[zebradoby]

test

[TonyJollans]

zebradody,

Please don't keep on adding test posts here; it wastes other people's time. There is a separate Testing area - http://vbaexpress.com/forum/forumdisplay.php?f=68 - if there is something you particularly need to test.

[zebradoby]

Ok Thanks Tony. I did not know about the testing area.

[fumei]

Yes, and please, you have been asked a couple of times.

Use the VBA tags when posting code.