#1
|
|||
|
|||
Hello,
I am trying to loop through all the headers in a document searching for a text string. If that string is found I would like to select it and the connected text to the left and pass the text value to a string variable so I can split and name the documents by these string values. I know this is a few parts but if you can help with any of the modules it would be much appreciated. 1. Loop through all headers 2 Search for text string, select entire word, save value to string 3. Export Page and name by string variable Any help is much appreciated. I found several sources for search and replace but the structure, ranges and object naming seems more complicated than necessary. I can provide some code that has yielded some results but seems off track. -Jeff Code:
Public Sub FindReplaceAnywhere() Dim rngStory As Word.Range Dim pFindTxt As String Dim pReplaceTxt As String Dim lngJunk As Long Dim oShp As Shape pFindTxt = "-IN" 'pReplaceTxt = "-IN**" 'From Sorce Code 'Fix the skipped blank Header/Footer problem 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 SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt On Error Resume Next Select Case rngStory.StoryType Case 6, 7, 8, 9, 10, 11 If rngStory.ShapeRange.Count > 0 Then For Each oShp In rngStory.ShapeRange If oShp.TextFrame.HasText Then SearchAndReplaceInStory oShp.TextFrame.TextRange, pFindTxt, pReplaceTxt 'FindIt oShp.TextFrame.TextRange, pFindTxt, pReplaceTxt End If Next End If Case Else 'Do Nothing End Select On Error GoTo 0 'Get next linked story (if any) Set rngStory = rngStory.NextStoryRange Loop Until rngStory Is Nothing Next End Sub Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String) Dim Invoice As String Dim rngInvoice As Range Dim strStart As Long Dim strEnd As Variant 'Best I could do, Prints the range of the area I want. Seems like I should be using .moveleft ? With rngStory If .Find.Execute(strSearch) Then Debug.Print .Start - 7 & " " & .End End With End Sub I found this which seems like it should be used to select the range but I'm struggling to name the header range and actually select the text I want Code:
With Selection Set MyRange = .GoTo(wdGoToField, wdGoToPrevious) .MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend If Selection.Fields.Count = 1 Then Selection.Fields(1).Update End With |
#2
|
||||
|
||||
There are potentially many headers in a document. You need to identify which section and which header in that section. The following example examines the primary header in the section where the cursor is when you run the macro. If necessary you can loop through all sections and the headers in those sections.
There is no need to 'select' the found word/string in order to read it and the word that comes before. Another issue not mentioned by Paul is what Word considers is a 'word', so when looking to add a word to a string, it helps to know what that 'word' might be. However the following should be easy enough to adapt. The string variable to which the search string and previous 'word' are added is sText Code:
Sub FindInHeader() Dim oRng As Range Dim sText As String Dim sWord As String Dim numWords As Integer Dim i As Integer Dim j As Integer numWords = 1 'In the following line set the section and the particular header Set oRng = Selection.Sections(1).Headers(wdHeaderFooterPrimary).Range sWord = InputBox("Enter the text to find") i = Len(sWord) For j = 1 To i If (Mid(sWord, j, 1)) = " " Then numWords = numWords + 1 End If Next j With oRng.Find Do While .Execute(FindText:=sWord, MatchWholeWord:=True) oRng.MoveStart wdWord, -1 Exit Do Loop End With If Not oRng.Words.Count = numWords + 1 Then sText = "" Else sText = oRng.Text End If If sText = "" Then MsgBox "Not found" Else MsgBox sText End If lbl_Exit: Set oRng = Nothing Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com Last edited by macropod; 07-15-2015 at 05:39 PM. Reason: Merging of multiple threads & overlapping posts deleted |
#3
|
|||
|
|||
Wow thank you guys. I had actually posted a similar thread with no reply with some code that was close. and then you guys just provided the missing link
https://www.msofficeforums.com/word-...e-varable.html Code:
rngStory.MoveStart wdWord, -1 How do I trace this post back to that one? I should be able to get those modules on my own, but perhaps I'll post another thread if I get hung up. Thanks again guys!! |
#4
|
|||
|
|||
Copy Page with Formatting
Hello all,
I am splitting a large document into individual documents by for each page. In the code below I am losing formatting. Is there a way to copy the formatting exactly? Do I need to copy the entire doc and delete all pages but the one I want? Do I need to use a template? Any help is appreciated. Code:
Sub SplitDoc() 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 strInvoice 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.PasteAndFormat Type:=wdFormatOriginalFormatting '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") 'strNewFileName = "Whatever" & ".doc" ' Usually a sting from differan Sub strNewFileName = "whatever" & ".PDF" docSingle.SaveAs strNewFileName, Word.WdSaveFormat.wdFormatPDF 'save the new single-paged document iCurrentPage = iCurrentPage + 1 'move to the next page docSingle.Close SaveChanges:=False '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. Set docMultiple = Nothing Set docSingle = Nothing Set rngPage = Nothing End Sub -Jeff |
#5
|
||||
|
||||
Rather than re-inventing the wheel, I suggest you take a look at the Split Merged Output to Separate Documents topic in the Mailmerge Tips and Tricks thread at:
https://www.msofficeforums.com/mail-...ps-tricks.html PS: I've merged your three threads, as they're all related.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
copy and paste, find, format, headers footers all pages, page count, range, select text, text |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Microsoft Word macro to find text, select all text between brackets, and delete | helal1990 | Word VBA | 4 | 02-05-2015 03:52 PM |
Macro for find/replace (including headers and footers) for multiple documents | jpb103 | Word VBA | 2 | 05-16-2014 04:59 AM |
How to find and select text in a document? | mkhuebner | Word VBA | 8 | 02-04-2014 08:04 PM |
Nested vlookup with varable tables! | Dave Jones | Excel | 0 | 08-30-2012 09:15 AM |
Unable to Select Multiple folders in Outlook 2007 Advance Find | gregory | Outlook | 2 | 04-28-2012 10:53 PM |