#31
|
|||
|
|||
Hi Paul,
Thanks for your response. Quote:
Quote:
Quote:
Thanks FLDS |
#32
|
||||
|
||||
Hi flds,
Try this new version of the 'ParseDocs' sub with other subs in my previous post: Code:
Sub ParseDocs() Application.ScreenUpdating = False Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, Sctn As Section, Rng As Range Dim DocSrc As Document, DocOutline As Document, DocTxt As Document, DocTbl As Document Dim DocApp As Document, DocRef As Document, oShp As Shape, iShp As InlineShape 'Call the GetFolder Function to determine the folder to process strInFold = GetFolder If strInFold = "" Then Exit Sub strFile = Dir(strInFold & "\*.doc", vbNormal) 'Check for documents in the folder - exit if none found If strFile <> "" Then strOutFold = strInFold & "\Output\" 'Test for an existing outpfolder & create one if it doesn't already exist If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold strFile = Dir(strInFold & "\*.doc", vbNormal) 'Process all documents in the chosen folder While strFile <> "" Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False) With DocSrc Set DocOutline = Documents.Add(Visible:=False) Call CreateOutline(DocSrc, DocOutline) 'Delete everything before the first Table Of Contents in the source document If .TablesOfContents.Count <> 0 Then Set Rng = .TablesOfContents(1).Range Rng.Start = .Range.Start Rng.Delete End If 'Delete any other Tables Of Contents in the source document For Each TOC In .TablesOfContents TOC.Delete Next TOC 'Convert all fields in the source document to plain text .Fields.Unlink With Content.Find .ClearFormatting .Replacement.ClearFormatting 'Convert non-breaking hyphens to ordinary hyphens .Text = "^~" .Replacement.Text = "-" .Execute Replace:=wdReplaceAll 'Delete manual page breaks .Text = "^m" .Replacement.Text = "" .Execute Replace:=wdReplaceAll End For Each oShp In .Shapes oShp.Delete Next oShp For Each iShp In .InlineShapes With iShp.Range.Paragraphs.First.Range With .Next.Paragraphs.First If .Style = "Caption" Then .Range.Delete End With .Delete End With Next iShp 'Check for tables in the source document If .Tables.Count > 0 Then 'If there are any tables in the source document, make a copy of the document .Range.Copy ' Create a new document for the tables Set DocTbl = Documents.Add(Visible:=False) 'Process the new document Call MakeTableDoc(DocTbl) End If 'Delete all tables in the source document For Each Tbl In .Tables Tbl.Delete Next Tbl 'Check for appendices in the source document For Each Sctn In .Sections If UCase(Trim(Sctn.Range.Words.First)) = "APPENDIX" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first appendices Section to the end of the 'source document and paste it into a new appendices document Rng.Cut Set DocApp = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocApp) Exit For End If Next Sctn 'Check for References in the source document For Each Sctn In .Sections If UCase(Trim(Sctn.Range.Words.First)) = "REFERENCES" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first References Section to the end of the 'source document and paste it into a new references document Rng.Cut Set DocRef = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocRef) Rng.End = .Range.End Rng.Cut Exit For End If Next Sctn 'Check for Design Requirements in the source document For Each Sctn In .Sections If UCase(Sctn.Range.Sentences.First) Like "#*DESIGN REQUIREMENT*" Then Set Rng = Sctn.Range 'Cut the 'Design Requirement' Section from the 'source document and paste it into a new references document Rng.Cut Set DocDesReq = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocDesReq) 'Delete everything after the 'Design Requirement' Section Rng.End = .Range.End Rng.Delete Exit For End If Next Sctn Call Cleanup(.Range) 'String variable for the output filenames strOutFile = strOutFold & Split(.Name, ".")(0) 'Copy whatever's left in the source document and paste it into a new text document .Range.Copy Set DocTxt = Documents.Add(Visible:=False) With DocTxt .Range.Paste 'Save and close the text document .SaveAs FileName:=strOutFile & "-Text", AddTorecentFiles:=False .Close End With Set DocTxt = Nothing 'Save and close the Outline document With DocOutline .SaveAs FileName:=strOutFile & "-Outline", AddTorecentFiles:=False .Close End With 'Save and close the tables document If Not DocTbl Is Nothing Then DocTbl.SaveAs FileName:=strOutFile & "-Tables", AddTorecentFiles:=False DocTbl.Close Set DocTbl = Nothing End If 'Save and close the appendices document If Not DocApp Is Nothing Then DocApp.SaveAs FileName:=strOutFile & "-Appendices", AddTorecentFiles:=False DocApp.Close Set DocApp = Nothing End If 'Save and close the references document If Not DocRef Is Nothing Then DocRef.SaveAs FileName:=strOutFile & "-References", AddTorecentFiles:=False DocRef.Close Set DocRef = Nothing End If 'Save and close the design requirements document If Not DocDesReq Is Nothing Then DocDesReq.SaveAs FileName:=strOutFile & "-Design Requirements", AddTorecentFiles:=False DocDesReq.Close Set DocDesReq = Nothing End If 'Close the source document without saving the changes we've made to it .Close SaveChanges:=False End With strFile = Dir() Wend Set Rng = Nothing: Set DocOutline = Nothing: Set DocSrc = Nothing Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#33
|
|||
|
|||
Hi Paul,
Thanks for the modified code. This is what I wanted, the code runs as expected. Just for one portion of the code “Design Requirements” is not as expected. Quote:
Code:
'Check for Design Requirements in the source document For Each Sctn In .Sections If UCase(Sctn.Range.Sentences.First) Like "#*DESIGN REQUIREMENTS*" Then Set Rng = Sctn.Range 'Cut the 'Design Requirement' Section from the 'source document and paste it into a new references document Rng.Cut Set DocDesReq = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocDesReq) 'Delete everything after the 'Design Requirement' Section Rng.End = .Range.End Rng.Delete Exit For End If Next Sctn This ‘#’ character does not seem to be a wildcard character in word 2007. With this ‘#’ character in place the file is not created in the output folder. When this ‘#’ character is removed I get the file in the output folder, but only 1 section that says ‘DESIGN REQUIREMENTS’, the other section that says ‘CONTROL DESIGN REQUIREMENTS’ is not created. Playing around with it, when I use a space "* DESIGN REQUIREMENTS*" it creates the ‘CONTROL DESIGN REQUIREMENTS’ section but not the ‘DESIGN REQUIREMENTS’ section. Frankly, I tried all the wildcard characters with no success. To get both sections into the output folder, I believe, there should be a solution. I am sure you will know the trick. Thanks FLDS |
#34
|
||||
|
||||
Hi flds,
The '#' character in a vba 'Like' stands for a digit. The '*' character stands for a string. Try using: If InStr(UCase(Sctn.Range.Sentences.First), "DESIGN REQUIREMENT") > 0 Then
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#35
|
|||
|
|||
Hi Paul,
Quote:
I tried, no success. It is same as before, it just creates one section. I also tried by inserting "*DESIGN REQUIREMENT*" no files were created. There should be a way to get this done. I hope to be successful. Thanks FLDS |
#36
|
||||
|
||||
Since you previously specified that the Design Requirements consisted of only one Section, that's all the code I wrote looks for! If there is more than one such Section, then you need to give some indication as to how one can reliably determine find how many such Sections there are. For example, does each such Section have the Words 'Design Requirements' or some form of that string as part of the first sentence in the Section? If not, is there always a 'Code and Standards' Section that follows the last 'Design Requirements' Section?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#37
|
||||
|
||||
Hi Paul,
Quote:
Quote:
Quote:
Quote:
Yes, 'Design Requirements' may also be part of a string of the first sentence in the section. I might have not correctly explained my requirements on 'Design Requirements' in my earlier post. Sorry for that. I hope I am now clear. Thanks FLDS |
#38
|
||||
|
||||
Quote:
Quote:
Quote:
Code:
Dim DocApp As Document, DocRef As Document, oShp As Shape, iShp As InlineShape Code:
Dim DocApp As Document, DocRef As Document, oShp As Shape, iShp As InlineShape, SubSctn As Section Code:
If InStr(UCase(Sctn.Range.Sentences.First), "DESIGN REQUIREMENT") > 0 Then Set Rng = Sctn.Range 'Cut the 'Design Requirement' Section from the 'source document and paste it into a new references document Rng.Cut Code:
If InStr(UCase(Sctn.Range.Sentences.First), "DESIGN REQUIREMENT") > 0 Then Set Rng = Sctn.Range Rng.End = .Range.End 'Find the end of the last 'Design Requirements' Section For Each SubSctn In Rng.Sections If InStr(UCase(SubSctn.Range.Sentences.First), "DESIGN REQUIREMENT") = 0 Then Rng.End = SubSctn.Range.Start - 1 Exit For End If Next 'Cut the 'Design Requirement' Sections from the 'source document and paste them into a a new design requirements document Rng.Cut
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#39
|
|||
|
|||
Hi Paul,
Thanks for your reply. I replaced and changed the lines as mentioned and test run the code. NO success. I am adding an outline of a document as an example, to give you an idea what is required. I need complete sections of 2 (Design Requirements) and sections 7 (CONTROL DESIGN REQUIREMENTS) ONLY. This example is not in all documents, - in ALL documents one section is always as section 2, - in some document it may be as sections 2 and 7 - in some documents it may be as Section 2, 7 or as section 10. Design Requirements Process Systems The words “DESIGN REQUIREMENTS” is common. Document Outline 1. INTRODUCTION 2. Design Requirements 2.1 Functional Requirements 2.2 Performance Requirements 2.2.1 Warm-Up 2.2.2 Start Up 2.3 Safety Requirements 2.3.1 General 3. PROCESS SYSTEM DESCRIPTION 3.1 General 3.1.1 System Arrangement 3.2 Equipment Description 3.2.1 Steam Generators 3.2.2 Heat Transport Pumps 3.2.2.1 General 4. Commissioning 4.1 Hydrostatic Test 4.2 Pump Operation without Fuel in the Reactor 4.2.1 General 5. OPERATION 5.1 Operating Conditions 5.2 Normal Operation 6. PROCESS DESIGN CONSIDERATIONS 6.1 Heat Transport System Operating Conditions 6.2 Fluid Velocities 7. CONTROL DESIGN REQUIREMENTS 7.1 General 7.2 System Classification 7.3 Safety Requirements 7.3.1 General 7.3.2 Seismic Qualification and PAM Requirements 8. CONTROL SYSTEM DESCRIPTION 8.1 General 8.2 Heat Transport Pump Motor Control 9. REFERENCES 9.1 System Flowsheets 9.2 Design Manuals Appendix I hope this will explains my requirements Thanks FLDS |
#40
|
||||
|
||||
Hi flds,
Change: SubSctn As Section to: i As Long and replace everything between: 'Check for Design Requirements in the source document and: 'String variable for the output filenames with: Code:
For Each Sctn In .Sections If InStr(UCase(Sctn.Range.Sentences.First), "DESIGN REQUIREMENT") > 0 Then Set Rng = Sctn.Range 'Delete anything after the first 'Design Requirements' Section that isn't 'also a 'Design Requirements' Section Rng.End = .Range.End For i = Rng.Sections.Count To 2 Step -1 If InStr(UCase(Rng.Sections(i).Range.Sentences.First), "DESIGN REQUIREMENT") = 0 Then _ Rng.Sections(i).Range.Delete Next 'Cut the 'Design Requirement' Sections from the source document 'and paste them into a new design requirements document Rng.Cut Set DocDesReq = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocDesReq) Exit For End If Next Sctn Call Cleanup(.Range)
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] Last edited by macropod; 07-14-2011 at 03:17 PM. Reason: Code refinements |
#41
|
|||
|
|||
Hi Paul,
Thank you so much. This is what I was looking for. If it was not for you I would have struggled doing all this manually. You have devoted so much of your precious time to help me solve my requirements. I hope I was not a disturbance, as I know you were studying for your exams and still helped me. I have no words to express my thanks to you. I wish you all the best. Thanks once again |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
copy and paste not working | Ellie | Word | 3 | 11-07-2013 02:23 PM |
Can't copy paste | irenasobolewska | Office | 2 | 10-26-2012 05:09 PM |
Copy - Paste between 2 tables | rod147 | Excel | 1 | 10-22-2009 08:21 PM |
Copy & paste low resolution | worriedme | Drawing and Graphics | 0 | 06-01-2009 03:05 AM |
Copy and paste special | Dace | Excel | 2 | 02-16-2009 12:18 PM |