Remove all text between 2 headers Word 2010, using VBA - vba

I have 2 headers or markers that are a part of my RTF document. In my example I am showing a sentence when in reality it will be multiple sentences or paragraphs. I have used brackets instead of less than and greater than signs as they disappear in my question. All I want to do is replace the text between the 2 markers with the following sentence, "text goes here", without quotation marks.
[EmbeddedReport]Lots of text, thousands of character, multiple paragraphs[/EmbeddedReport]
I want replace all the text between the 2 markers replaced with "text goes here".
It would end up looking like this...
"[EmbeddedReport]text goes here[/EmbeddedReport]"
I've literally spent 2 days trying to solve this. Any help would be appreciated.
This is the last thing I tried...
Sub RemoveReport()
Dim c As Range
Dim StartWord As String, EndWord As String
Selection.HomeKey Unit:=wdStory
StartWord = "<ImageTable>"
EndWord = "</ImageTable>"
Set c = ActiveDocument.Content
c.Find.ClearFormatting
c.Find.Replacement.ClearFormatting
With c.Find
.Text = StartWord & "*" & EndWord
' MsgBox (.Text)
.Replacement.Text = "<ImageTable>text goes here</ImageTable>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
c.Find.Execute
While c.Find.Found
Debug.Print c.Text
'~~> I am assuming that the start word and the end word will only
'~~> be in the start and end respectively and not in the middle
Debug.Print Replace(Replace(c.Text, StartWord, ""), EndWord, "")
c.Find.Execute
Wend
End Sub

Word VBA is not my area of expertise, but it seems similar to a question I answered a few days ago.
Turns out the wildcard match was not doing what I hoped it would do, or at least it was not reliable. Also, I ran in to some trouble using angle brackets, so this uses square brackets. I suspect that word treats the angle brackets as markup/syntax, and thus does not interpret them as text in the Find object. There is probably a way around this, but Word VBA is not my specialty. There is also probably a more elegant solution, but again, Word VBA is not my specialty :)
Try something like this:
Option Explicit
Sub Test()
Dim doc As Document
Dim txtRange As Range
Dim startTag As String
Dim endTag As String
Dim s As Long
Dim e As Long
startTag = "[EmbeddedReport]"
endTag = "[/EmbeddedReport]"
Set doc = ActiveDocument
Set txtRange = doc.Content
'Find the opening tag
With txtRange.Find
.Text = startTag
.Forward = True
.Execute
If .Found Then
s = txtRange.Start
Else
GoTo EarlyExit
End If
End With
'Find the closing tag
Set txtRange = doc.Range(txtRange.End, doc.Content.End)
With txtRange.Find
.Text = endTag
.Forward = True
.Execute
If .Found Then
e = txtRange.End
Else
GoTo EarlyExit
End If
End With
Set txtRange = doc.Range(s, e)
txtRange.Text = startTag & "text goes here" & endTag
Exit Sub
EarlyExit:
MsgBox "Header not found in this document!", vbInformation
End Sub
It takes some time to figure it out at first, but learning to navigate the object model reference documentation for VBA will make these tasks a lot easier to figure out in the future.

Related

Macro Multiple find and replace (over 500) in Word Docx

Just wanted to say people who can code are seriously next level,
I am unfortunately not one of those people.
I'v been set a task at work, which I assume there must be a quicker way to complete.
After research I came across this, but it only works for 15 words at a time, but I have around 500 words to find and replace, which I had been doing manually.
Any adaptations, if you dont mind, please dumb it down for me, all I know is how to paste to Visual Basic and run. I can input comma separated values/paths.
Sub FindAndReplaceMultiItems()
Dim strFindText As String
Dim strReplaceText As String
Dim nSplitItem As Long
Application.ScreenUpdating = False
' Enter items to be replaces and new ones.
strFindText = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found")
strReplaceText = InputBox("Enter new items here, seperated by comma: ", "New items")
nSplitItem = UBound(Split(strFindText, ","))
' Find each item and replace it with new one respectively.
For nSplitItem = 0 To nSplitItem
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Split(strFindText, ",")(nSplitItem)
.Replacement.Text = Split(strReplaceText, ",")(nSplitItem)
.Format = False
.MatchWholeWord = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End With
Next nSplitItem
Application.ScreenUpdating = True
End Sub
Any help would be very appreciated : )
Bonus Question: How to apply all these find and replacements to 900 documents?
Example data: (Controlled documents so I cant share real data unfortunately)
A dfe-tbh,scf-b9jt,dvf-hnk,pol-jbv,dn-fgm,gh-jkl
B df12-hbt,dvf-dgf,hj-gngk,dbs-ghdn,fbh-ghg,gfn-dhn

how to search multiple string (either of the string from the list) in a paragraph (updated with input & output images)

My goal is to merge multiple paragraph based on predefined string (in an arrary) such as period (.) or question mark (?)
My sample sentence is as below (refer the image please):
Input
The expected result will be something like this.
////////////////////////////////////////////////////////
Output
////////////////////////////////////////////////////////
In the below code, I could achieve it using period (.), but for every other end string, I have separate macro. Depends on the end string, I run different macro. Is there way to put all these search string (. / ? / ;) in a single array and ask the code to run until it find either of them and exit from the loop and do the merge?
Blockquote
Sub FindDotToJoinParagraph()
Dim xRange As Range
Dim Srt As Variant
Dim Endee As Variant
Dim currentPosition As Range
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="Srt" 'Bookmark
With Selection.Find
.Text = "." 'Here not just period alone, but others too
.Replacement.Text = ""
.Forward = True
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.EndKey Unit:=wdLine, Extend:=wdMove
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="Ends" 'Bookmark
ActiveDocument.Range( _
ActiveDocument.Bookmarks("Srt").Range.Start, _
ActiveDocument.Bookmarks("Ends").Range.Start) _
.Select
call MergeParaAndLineBreaks() 'An another sub-routine to merge
End Sub
//////////////////////////////////
Sub MergeParaAndLineBreaks()
Dim oRng As Range
Set oRng = Selection.Range
Dim oFind As Range
Set oFind = Selection.Range
With oFind.Find
Do While .Execute(findtext:="[^13^l]{1,}", MatchWildcards:=True)
If oFind.InRange(oRng) Then
oFind.Text = ""
End If
Loop
End With
Set oFind = oRng
With oFind.Find
Do While .Execute(findtext:="[ ]{2,}", MatchWildcards:=True)
If oFind.InRange(oRng) Then
oFind.Text = Chr(32)
oFind.Collapse 0
End If
Loop
End With
lbl_Exit:
Set oRng = Nothing
Set oFind = Nothing
Exit Sub
End Sub
Blockquote
Could someone help me out, please!
As noted in my comments, paragraphs don't necessarily end at punctuations marks. That said, a crude but effective solution to achieve the results you've described would be to use a wildcard Find/Replace, where:
Find = ([!.\!\?;:])^13
Replace = ^32\1
IOW, you don't even need a macro. Since we don't know whether there are spaces preceding the paragraph breaks in your source text, you may end up with some extra spaces - which you could clean up with another Find/Replace (or you might omit the ^32 from the Replace expression).

Writing a Word Macro to Compare Values in Two Separate Documents

I am attempting to write a macro that will automatically verify that the forms present in two documents are the same.
To do this I need to search through one document and create an array that is a list of all of the forms in that document. Each form is designated by a unique code like AB001 or E363. I am currently searching for these terms and highlighting them using this code I blatantly stole off the internet.
Dim word As Range
Dim wordcollection(9) As String
Dim words As Variant
'Define list.
'If you add or delete, change value above in Dim statement.
wordcollection(0) = "PJ"
wordcollection(1) = "E1233"
wordcollection(2) = "E048"
wordcollection(3) = "E144"
wordcollection(4) = "E849"
wordcollection(5) = "E977"
wordcollection(6) = "IL0021"
wordcollection(7) = "MISC001"
wordcollection(8) = "CG0001"
wordcollection(9) = "CG2107"
'Set highlight color.
Options.DefaultHighlightColorIndex = wdYellow
'Clear existing formatting and settings in Find feature.
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'Set highlight to replace setting.
Selection.Find.Replacement.Highlight = True
'Cycle through document and find words in collection.
'Highlight words when found.
For Each word In ActiveDocument.words
For Each words In wordcollection
With Selection.Find
.Text = words
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
End Sub
I need to figure out how to copy the values that are present in the document into a new array
Then I need to search another document for the same values and copy the values that are present in that document into another new array
Finally I need to compare both of the new arrays and print a list of the values that are present in new array A but not new array b and vice versa.
Any help would be appreciated. The extent of my VBA experience is writing macros to automatically copy data in formfields to new formfields so even a basic understanding of how to do this would be appreciated.
Thanks!
Doing a ReplaceAll in your existing code doesn't give you any runtime feedback. You have to isolate the Found variable and then you can determine what to do. My recommendation is to separate the single macro into two parts with the second macro providing the feedback that the code was found so that you can then take action.
To provide you with an example of what I am attempting to describe, below is an example and the output are separate text files that show what codes exist in each document. Hopefully you can adapt this to meet your requirements.
Sub FindCodes()
Dim doc As word.Document
Dim i As Long, wrkFolder As String, fName As String
Dim oFile As String, FileNum As Integer
Dim Codes(0 To 2) As String
Codes(0) = "PJ"
Codes(1) = "E1233"
Codes(2) = "E048"
On Error GoTo errHandler
wrkFolder = "c:\users\<your id>\documents\test\"
fName = Dir(wrkFolder & "*.docx", vbNormal)
Do While fName <> vbNullString
Set doc = Documents.Open(wrkFolder & fName)
oFile = Left(doc.FullName, InStrRev(doc.FullName, ".") - 1) & "_Codes.txt"
On Error Resume Next
Kill oFile
On Error GoTo errHandler
FileNum = FreeFile()
Open oFile For Append As #FileNum
Print #FileNum, doc.Name
For i = 0 To UBound(Codes)
If Not CheckDocument(doc, Codes(i)) = vbNullString Then
'the code was found in the document
'print it in a text file
Print #FileNum, Codes(i)
End If
Next
Close #FileNum
doc.Save
doc.Close
fName = Dir()
Loop
errHandler:
If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation, "Find Codes"
Err.Clear
End If
End Sub
Private Function CheckDocument(ByRef doc As word.Document, StrCode As String) As String
Dim rng As word.Range
For Each rng In doc.StoryRanges
'will search headers, footers and the document body
With rng.Find
.ClearFormatting
.Format = True
.Forward = True
.MatchCase = True
.MatchWholeWord = True
.Text = StrCode
.Wrap = wdFindStop
.Execute
If .Found Then
'this will highlight the first code found and then exit
'does it really need to highlight all places the code
'was found? If so, comment out this IF statement and
'use the loop method instead
rng.HighlightColorIndex = wdYellow
CheckDocument = .Text
Exit Function
End If
' Do While .Found
' rng.HighlightColorIndex = wdYellow
' CheckDocument = .Text
' Loop
End With
Next
End Function

vba ms-word find text and get adjacent number

I am working with Word Docs containing quite a lot of pages and formulas.
I have an array containing expressions
dim YellowWord(1 to 100) as string
I want to start at the beginning of the word text to look for every of those words and have a look the instances where that word or expression is followed by a number or numbers into brackets
EXMAPLE:
yellowword(2)="the blue table"
using wildcards I can find: the blue table (34, 23) in the text.
what I want is filling another array that would be:
yellowwood_reference(2) = "(34, 23)"
the code I have is so:
for i=1 to NRofYellowWords
with active document.content.find
.clearformating
.text = yellowWord(i) & " " & "\((*)\)"
with .replacement
.clearformating
.text = yellowWord(i) & "(\1)"
'HERE IS WHERE I WANT TO SAY TO WORD:
'PUT THAT PART "(\1)" INTO A VARIABLE YELLOWWORD_REFERENCE(i)
'HOWW??????
.font.color = wdcolorred
'here i changed the color of the string with the references into red.
end with
.fordward = true
.wrap = wdfindcontinue
.format = true
.matchcase = false
.matchewholeword = false
.matchwildcards = true
.matchsoundslike = false
.matchallwordforms= false
.execute replace:=wdreplaceall
end with
next i
In the above code there are several problems:
the first one I wrote it in capital letters, getting that reference of the wild card into a variable.
The second one is that there might be many appearances of the YellowWord(2) in the text, I only need/want the first reference, not the rest. That means that the first time the code finds the blue table (24,26) after passing the value "(24, 26)" into another array the code should move on and not look for more instances of the blue table in the text.
btw, i used wildcards because there might be the case that the references are simple not into brackets, so i would have to run everything twice with a different wildcard.
By the way as you can imagine, once I get the array yellowWord_reference(i) I would add the references there where there are instances of YellowWord without refferences.
I would really appreciate help since I really clicked many websites with little success.
thanks a lot
cheers
PS: If you think that there is a better way to do all that without using .find just mention it please, i am quite new in Ms-Word and coming from VBA Excel i get headaches figuring out where is the selection point.
I modified your code so that if it finds your 'words', it will capture the numbers that follow.
The code you posted would never work due to the number of compile errors ... strongly suggest you start using "Option Explicit" and posting actual code rather than typing in in yourself.
Other notes:
The numbers are enclosed in parenthesis () - not brackets []
You were using a 'ReplaceAll'; if you only wanted the first occurance, change from '...All'
I removed the 'red font' and 'Replace' ... add it back if needed.
Your code would remove the space between the word and the number - is that what you wanted?
Here's the code:
Option Explicit
Sub Find_Words()
Dim yellowWord(100) As String
Dim yellowwood_reference(100) As String
Dim NRofYellowWords As Integer
Dim i As Integer
Dim lS As Long
Dim lE As Long
Dim sFound As String
Dim rng As Range
yellowWord(1) = "blue table"
yellowWord(2) = "little"
yellowWord(3) = "big"
yellowWord(4) = "xxx last xxx"
NRofYellowWords = 4
Set rng = ActiveDocument.Range
For i = 1 To NRofYellowWords
With rng.Find
.Text = yellowWord(i) & " " & "\((*)\)"
With .Replacement
.Text = yellowWord(i) & "(\1)"
End With
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .Found Then
' Find (numbers) & save
lS = InStr(rng.Start, ActiveDocument.Range.Text, "(")
If lS > 0 Then
lE = InStr(lS, ActiveDocument.Range.Text, ")")
sFound = Mid(ActiveDocument.Range.Text, lS, lE - lS + 1)
yellowwood_reference(i) = sFound
Debug.Print "Found: " & yellowWord(i) & vbTab & sFound
Else
MsgBox "Bad format; missing '('" & vbTab & Mid(ActiveDocument.Range.Text, lS, 50)
End If
Else
Debug.Print "Not Found: " & yellowWord(i)
End If
End With
Next i
Debug.Print "Finished"
End Sub

To delete everything except for words between a start and end point

I happen to have problems trying to manipulate the below code to my liking.
First off, the code below deletes everything in between the start and end conditions I have stipulated in my program.
I would like to change this, to delete everything besides those stipulated between the start and end words.
Sub SomeSub()
Dim StartWord As String, EndWord As String
Dim Find1stRange As Range, FindEndRange As Range
Dim DelRange As Range, DelStartRange As Range, DelEndRange As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Setting up the Ranges
Set Find1stRange = ActiveDocument.Range
Set FindEndRange = ActiveDocument.Range
Set DelRange = ActiveDocument.Range
'Set your Start and End Find words here to cleanup the script
StartWord = "From: Research.TA#traditionanalytics.com|Tradition Analytics Commentary| | |"
EndWord = "This message has been scanned for malware by Websense. www.websense.com"
'Starting the Find First Word
With Find1stRange.Find
.Text = StartWord
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
'Execute the Find
Do While .Execute
'If Found then do extra script
If .Found = True Then
'Setting the Found range to the DelStartRange
Set DelStartRange = Find1stRange
'Having these Selections during testing is benificial to test your script
DelStartRange.Select
'Setting the FindEndRange up for the remainder of the document form the end of the StartWord
FindEndRange.Start = DelStartRange.End
FindEndRange.End = ActiveDocument.Content.End
'Having these Selections during testing is benificial to test your script
FindEndRange.Select
'Setting the Find to look for the End Word
With FindEndRange.Find
.Text = EndWord
.Execute
'If Found then do extra script
If .Found = True Then
'Setting the Found range to the DelEndRange
Set DelEndRange = FindEndRange
'Having these Selections during testing is benificial to test your script
DelEndRange.Select
End If
End With
'Selecting the delete range
DelRange.Start = DelStartRange.Start
DelRange.End = DelEndRange.End
'Having these Selections during testing is benificial to test your script
DelRange.Select
'Remove comment to actually delete
DelRange.Delete
End If 'Ending the If Find1stRange .Found = True
Loop 'Ending the Do While .Execute Loop
End With 'Ending the Find1stRange.Find With Statement
End Sub
Hah! That's a new twist There's certainly more than one way to go about it; my inclination would be to work with (at least) three Ranges. Something like this:
Sub FindAndDeleteEverythingElse()
Dim strFind1 As String, strFind2 As String
Dim rngDoc As word.Range, rngFind1 As word.Range
Dim rngFind2 As word.Range
Dim bFound As Boolean
strFind1 = "You"
strFind2 = "directly."
Set rngDoc = ActiveDocument.content
Set rngFind1 = rngDoc.Duplicate
Set rngFind2 = rngDoc.Duplicate
With rngFind1.Find
.Text = strFind1
bFound = .Execute
End With
If bFound Then
With rngFind2.Find
.Text = strFind2
bFound = .Execute
End With
If bFound Then
rngDoc.End = rngFind1.Start
rngDoc.Delete
rngDoc.Start = rngFind2.End
rngDoc.End = ActiveDocument.content.End
rngDoc.Delete
End If
End If
End Sub
The "main" Range is that of the entire document: ActiveDocument.Content. The Range object is a bit different than other objects, if you set one Range to another it becomes that Range, not a copy. So you need the Duplicate method to make a copy of a Range. This lets you use Find independently for the various Ranges.
If the first Find is successful, the second one is executed. If that is also successful then the Document Range's end-point is set to the starting point of the successful Find and the content of the Range deleted. The Document Range is then re-defined to start at the end-point of the second found Range and end at the end of the Document, and deleted.
You will probably have to set more Range.Find properties than I did in this code snippet - I used the absolute minimum to make working with the Ranges clearer.
There maybe another way but till then you can do this.
try to add dummy character after and before your string like this
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
.Text = "From: Research.TA#traditionanalytics.com|Tradition Analytics Commentary| | |"
.Replacement.Text = "From: Research.TA#traditionanalytics.com|Tradition Analytics Commentary| | |######"
.Execute Replace:=wdReplaceAll
.Text = "This message has been scanned for malware by Websense. www.websense.com"
.Replacement.Text = "######This message has been scanned for malware by Websense. www.websense.com"
.Execute Replace:=wdReplaceAll
End With
End With
End Sub
Then try to set range between ###### and ######
this is best answer to set range select a range of text from one Word document and copy into another Word document
Please note that in my word 2007 it is not possible to find within hyperlinks. Try to remove all hyperlink or within range before doing replacement.
another best answer for that: How do you remove hyperlinks from a Microsoft Word document?