I am working on a macro in word. It pulls cell contents from some cells in an excel doc, puts part of them at the end of the word doc, bolds the first part, then puts the rest of the string and unbolds it.Then it looks for the next match in the excel doc and repeats until there are no matches.
On the second pass through the loop, it continues to affect the content added in the first pass. The font with block also affects the previous line and ends up bolding the entire thing. I set the object to Nothing at the end of the function so I wouldn't expect it to see the first part of the loop as part of the range any longer.
Do
x = AssembleSentence(Last, First, Rank)
Set Loc = .FindNext(Loc)
Loop While Not Loc Is Nothing And Loc.Address <> sFirstFind
Function AssembleSentence(Last, First, Rank)
Dim sText0 As String, sText As String, oText As Object
Set oText = ActiveDocument.Content
sText0 = First & " " & Last
sText = ", " & Rank & " Professor at College of Hard Knocks."
Set oText = ActiveDocument.Content.Paragraphs.Add
oText.Range.SetRange Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End
Selection.EndKey Unit:=wdStory
With oText.Range
.InsertAfter (sText0)
With .Font
.Bold = True
End With
End With
Selection.EndKey Unit:=wdStory
With Selection
.Text = sText
With .Font
.Bold = False
End With
End With
Selection.EndKey Unit:=wdStory
Set oText = Nothing
End Function
Still unsure why the loop doesn't redo the range to the end on its own, but this fixes it so that it stops affecting prior looped content.
Looking at my oText.range start/end properties it looks like it is 1034/1035 with a length of 1036 on the first pass and then 1036/1209 with a length of 1210 on the second pass. That is the issue - I don't know why it isn't 1208/1209 on the second pass after setting the object to nothing at the end of the first pass, but the following edit fixes the issue.
With oText.Range
.SetRange Start:=oText.Range.End, End:=oText.Range.End
.InsertAfter (sText0)
With .Font
.Bold = True
End With
End With
Related
I am trying to make my macro bring up a search box that allows me to enter as many words as I want, separated by comma, and then find each word in the list in the document and make them bold and blue. I my code isn't working.
I'm at my wits and and this should have been a simple macro to write in 5 minutes. I am new at this, of course.
Sub BlueWords()
Dim blueword As String
Dim numberofwords As Long
Application.ScreenUpdating = False
' Enter words that need to become bold blue words.
blueword = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found")
numberofwords = UBound(Split(blueword, ","))
' Find each item and replace it with new one respectively.
For numberofwords = 0 To numberofwords
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Split(blueword, ",")(numberofwords)
.blueword.Font.Color.RGB = Split(RGB(255, 0, 0), ",")(numberofwords)
.Format = False
.MatchWholeWord = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End With
Next numberofwords
Application.ScreenUpdating = True
End Sub
I expect it to work, but I think it all goes off the rails where I'm trying to make the code actually perform the bold and blue part. Of course, it won't run.
The below code works like this
startSearch saves the input from the input box as a string, splits it into an array and loops over the individual words. In each loop, it calls findCells.
findCells uses the .Find function to search the selected range (before you start the macro) for cells that contain the word of the current loop. Then it loops over the found range (making sure not to get into an infinite loop) and calls modifyCell.
modifyCell disables the change event and makes the celltext blue and bold.
startSearch:
Sub startSearch()
Dim inputString As String
Dim inputArray() As String
Dim wordsArray() As Variant
Dim selRange As Range
Application.ScreenUpdating = False
' Enter words that need to become bold blue words.
inputString = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found")
inputArray = Split(inputString, ",")
' Create Array out of input.
ReDim wordsArray(LBound(inputArray) To UBound(inputArray))
Dim index As Long
For index = LBound(inputArray) To UBound(inputArray)
wordsArray(index) = inputArray(index)
Next index
' Determine Selection
Set selRange = Selection
' Loop through array/each word and find them in a range (then modify them).
For Each word In wordsArray
Call findCells(selRange, word)
Next word
Application.ScreenUpdating = True
End Sub
findCells:
Private Sub findCells(searchRange, content)
Dim foundCell As Range
Dim firstFound As String
With searchRange
' Find range of cells that contains relevant word
Set foundCell = .Find(What:=content, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
' If any cells containing the word were found, then modify them one by one
If Not foundCell Is Nothing Then
' Save first found cell, LOOP over found cells, modify them, go to next cell, until back to the first one
firstFound = foundCell.Address
Do
Call modifyCell(foundCell)
Set foundCell = .FindNext(foundCell)
Loop Until foundCell.Address = firstFound
End If
End With
End Sub
modifyCell:
Private Sub modifyCell(TargetCell As Range)
' disable change event while modifying cells
Application.EnableEvents = False
TargetCell.Font.Color = RGB(0, 0, 255)
TargetCell.Font.Bold = True
Application.EnableEvents = True
End Sub
This line of code .blueword.Font.Color.RGB = Split(RGB(255, 0, 0), ",")(numberofwords) will not work.
RGB() will return a number representing a colour. So the Split
returns an array of 1 (index = 0). As a result, your line of code
will cause an 'index out of bounds' error.
.blueword is not a member of Find
.Font.Color.RGB = RGB(0,0,255) should turn the text blue easily
enough!
There are other issues in the code, and you will probably come across other errors.
Instead of using Split so many times, why not save it to an array variable and just loop through the array - so much cleaner!
I have a Word macro that allows to put his/her cursor anywhere in a Word document and it finds and saves the Heading 1, Heading 2 and Heading 3 text that is above the text selected by the user in order capture the chapter, section and sub-section that is associated with any sentence in the document.
I am currently using the code below which moves up the document line-by-line until it finds a style that contains "Heading x". When I have completed this task I move down the number of lines that I moved up to get to Heading 1, which may be many pages.
As you can imagine this is awkward, takes a long time (sometimes 60+ seconds) and is visually disturbing.
The code below is that subroutine that identifies the heading.
Dim str_heading_txt, hdgn_STYLE As String
Dim SELECTION_PG_NO as Integer
hdng_STYLE = Selection.Style
Do Until Left(hdng_STYLE, 7) = "Heading"
LINESUP = LINESUP + 1
Selection.MoveUp Unit:=wdLine, COUNT:=1
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
hdng_STYLE = Selection.Style
'reached first page without finding heading
SELECTION_PG_NO = Selection.Information(wdActiveEndPageNumber)
If SELECTION_PG_NO = 1 Then 'exit if on first page
a_stop = True
Exit Sub
End If
Loop
str_heading_txt = Selection.Sentences(1)
I tried another approach below in order to eliminate the scrolling and performance issues using the Range.Find command below.
I am having trouble getting the selection range to move to the text with the "Heading 1" style. The code selects the sentence at the initial selection, not the text with the "Heading 1" style.
Ideally the Find command would take me to any style that contained "Heading" but, if required, I can code separately for "Heading 1", "Heading 2" and "Heading 3".
What changes to the code are required so that "Heading 1" is selected or, alternatively, that "Heading" is selected?
Dim str_heading_txt, hdgn_STYLE As String
Dim Rng As Range
Dim Fnd As Boolean
Set Rng = Selection.Range
With Rng.Find
.ClearFormatting
.Style = "Heading 1"
.Forward = False
.Execute
Fnd = .Found
End With
If Fnd = True Then
With Rng
hdng_STYLE = Selection.Style
str_heading_txt = Selection.Sentences(1)
End With
End If
Any assistance is sincerely appreciated.
You can use the range.GoTo() method.
Dim rngHead As Range, str_heading_txt As String, hdgn_STYLE As String
Set rngHead = Selection.GoTo(wdGoToHeading, wdGoToPrevious)
'Grab the entire text - headers are considered a paragraph
rngHead.Expand wdParagraph
' Read the text of your heading
str_heading_txt = rngHead.Text
' Read the style (name) of your heading
hdgn_STYLE = rngHead.Style
I noticed that you used Selection.Sentences(1) to grab the text, but headings are already essentially a paragraph by itself - so you can just use the range.Expand() method and expand using wdParagraph
Also, a bit of advice:
When declaring variables such as:
Dim str_heading_txt, hdgn_STYLE As String
Your intent was good, but str_heading_txt was actually declared as type Variant. Unfortunately with VBA, if you want your variables to have a specific data type, you much declare so individually:
Dim str_heading_txt As String, hdgn_STYLE As String
Or some data types even have "Shorthand" methods known as Type Characters:
Dim str_heading_txt$, hdgn_STYLE$
Notice how the $ was appended to the end of your variable? This just declared it as a String without requiring the As String.
Some Common Type-Characters:
$ String
& Long
% Integer
! Single
# Double
You can even append these to the actual value:
Dim a
a = 5
Debug.Print TypeName(a) 'Prints Integer (default)
a = 5!
Debug.Print TypeName(a) 'Prints Single
Try something based on:
Sub Demo()
Dim Rng As Range, StrHd As String, s As Long
s = 10
With Selection
Set Rng = .Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
StrHd = Rng.Paragraphs.First.Range.Text
Do While Right(Rng.Paragraphs.First.Style, 1) > 1
Rng.End = Rng.Start - 1
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
With Rng.Paragraphs.First
If Right(.Style, 1) < s Then
s = Right(.Style, 1)
StrHd = .Range.Text & StrHd
End If
End With
Loop
MsgBox StrHd
End With
End Sub
I'm new to using VBA to write macros within MS Word. I've worked out how to select the cell within the table, but it doesn't appear I can use the paragraph object with it... or, more likely, I'm doing it wrong.
Essentially, what I'm trying to do, it look for phrase "as follows:" within all the paragraphs of Cell (13,2) of Table(1). If it finds it, I want to see if the next thing that happens after that phrase is a new paragraph with a bullet. If it is, great, nothing more to do. If it isn't, then do a new paragraph with a bullet.
I'm just not sure how to go about this, particularly determining if there is already a bullet or not.
Hoping someone can throw some light on the subject. I'll keep plugging away in the meantime. :)
UPDATE: I've gotten this far where it inserts a return and I was hoping would insert a bullet but it is inserting a bullet in numerous spaces in that Cell rather than after the vbCr:
Dim BIOCell As range
With ActiveDocument
Set BIOCell = .range(Start:=.Tables(1).Cell(13, 2).range.Start, _
End:=.Tables(1).Cell(13, 2).range.End)
BIOCell.Select
End With
With ActiveDocument.Tables(1)
If .Cell(13, 2).range.Text Like "*as follows:*" Then
With Selection.Find
.Text = "as follows: "
.Replacement.Text = "as follows:" & vbCr
Selection.range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
.Execute Replace:=wdReplaceAll
End With
Else
MsgBox "couldn't find it"
End If
End With
I've modified your code sample and this works for me. Since you already declare and assign a Range to BIOCell you can use that throughout your macro to identify the cell contents. There's no need to use the "Like" test since Range.Find.Execute returns True if successful, otherwise False. When Find is successful, the Range will change to what has been found (in other words it's no longer the entire cell).
Trying to replace with a paragraph mark isn't working as you wish. Since you need to do something that can't be done with Find/Replace anyway (the bullets) simply add the paragraph mark if Find is successful, put the Range focus at the end of the cell, than apply the Bullets formatting. (Note that there's no need to use Selection if you have the Range object.)
Sub FindInCellAppendBullets()
Dim BIOCell As Range
Dim found As Boolean
With ActiveDocument
Set BIOCell = .Range(Start:=.Tables(1).Cell(13, 2).Range.Start, _
End:=.Tables(1).Cell(13, 2).Range.End)
BIOCell.Select
End With
With BIOCell.Find
.Text = "as follows: "
found = .Execute
If found Then
BIOCell.InsertParagraphAfter
BIOCell.Collapse wdCollapseEnd
BIOCell.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
Else
MsgBox "couldn't find it"
End If
End With
End Sub
If the table cell already has paragraphs of text and you want everything after the Find term to be bulleted, then the code could look like the example that follows.
In this case, a second Range object is used to perform the Find, while BIOCell remains assigned to the entire cell. (Always use the Duplicate property to make a "copy" of a Range that can be used independently. Range is an anamoly in the Office object models: Range=Range makes both Ranges identical - if you change the position of one, the position of the other changes, as well.)
Once Find is successful, the findRange is collapsed to the end of the Find term and moved one paragraph further (to the first paragraph following the found text). The end of the Range is then extended to the end of the cell (end of BIOCell), then moved back a couple of characters so that it doesn't include the end-of-cell markers. (Otherwise the bullets would be applied to the entire cell instead of up through the last paragraph of the cell.)
Sub FindInCellFormatWithBullets()
Dim BIOCell As Range
Dim findRange As Range
Dim found As Boolean
With ActiveDocument
Set BIOCell = .Range(Start:=.Tables(1).Cell(13, 2).Range.Start, _
End:=.Tables(1).Cell(13, 2).Range.End)
Set findRange = BIOCell.Duplicate
BIOCell.Select
End With
With findRange.Find
.Text = "as follows: "
found = .Execute
If found Then
findRange.MoveStart wdParagraph, 1
findRange.End = BIOCell.End - 2
findRange.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior
Else
MsgBox "couldn't find it"
End If
End With
End Sub
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
With ActiveDocument.Tables(1).Cell(13, 2)
Set Rng = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "as follows:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If .Find.Found = False Then
MsgBox "couldn't find it"
Exit Sub
End If
Do While .Find.Found
If .InRange(Rng) Then
If .Characters.Last.Next <> vbCr Then .InsertAfter vbCr & vbCr
If .Paragraphs.Last.Next.Range.ListFormat.ListType <> wdListBullet Then
If Len(.Paragraphs.Last.Next.Range.Text) > 1 Then .InsertAfter vbCr
.Paragraphs.Last.Next.Range.ListFormat.ApplyListTemplateWithLevel _
ListTemplate:=ListGalleries(wdBulletGallery).ListTemplates(1), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, _
DefaultListBehavior:=wdWord10ListBehavior
End If
Else
Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
Unlike Cindy's code, the above will insert a bullet paragraph regardless of whether the 'as follows:' string terminates with a paragraph break (or anything other than a space) when the following paragraph isn't a bulleted one.
I have a code like so:
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedWords As Range
Dim selectedText As String
Const punctuation As String = " & Chr(145) & "
On Error GoTo ErrorReport
' Cancel macro when there's no text selected
Selection.Cut
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Set selectedWords = Selection.Range
selectedText = selectedWords
If InStr(selectedText, punctuation) = 0 Then
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Else
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Selection.Paste
Selection.Paste
Selection.Paste
End If
ErrorReport:
End Sub
Basically, it help me move whatever text I have selected to the beginning of the sentence in Word. If there's no quotation mark, then paste once. If there is a quote mark, paste 4 times.
The problem is regardless of whether there's any quotation there or not, it will only paste once. If I set the macro to detect any other character, it will work fine. But every single time I try to force it to detect smart quotations, it will fail.
Is there any way to fix it?
Working with the Selection object is always a bit chancy; on the whole, it's better to work with a Range object. You can have only one Selection; you can have as many Ranges as you need.
Because your code uses the Selection object it's not 100% clear what the code does. Based on my best guess, I put together the following example which you can tweak if it's not exactly right.
At the beginning, I check whether there's something in the selection, or it's a blinking insertion point. If no text is selected, the macro ends. This is better than invoking Error handling, then not handling anything: If other problems crop up in your code, you wouldn't know about them.
A Range object is instantiated for the selection - there's no need to "cut" it, as you'll see further along. Based on this, the entire sentence is also assigned to a Range object. The text of the sentence is picked up, then the sentence's Range is "collapsed" to its starting point. (Think of this like pressing the left arrow on the keyboard.)
Now the sentence's text is checked for the character Chr(145). If it's not there, the original selection's text (including formatting) is added at the beginning of the sentence. If it's there, then it's added four times.
Finally, the original selection is deleted.
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedText As String
Dim punctuation As String
punctuation = Chr(145) ' ‘ "smart" apostrophe
Dim selRange As word.Range
Dim curSentence As word.Range
Dim i As Long
' Cancel macro when there's no text selected
If Selection.Type = wdSelectionIP Then Exit Sub
Set selRange = Selection.Range
Set curSentence = selRange.Sentences(1)
selectedText = curSentence.Text
curSentence.Collapse wdCollapseStart
If InStr(selectedText, punctuation) = 0 Then
curSentence.FormattedText = selRange.FormattedText
Else
For i = 1 To 4
curSentence.FormattedText = selRange.FormattedText
curSentence.Collapse wdCollapseEnd
Next
End If
selRange.Delete
End Sub
Please check out this code.
Sub MoveToBeginningSentence()
' 19 Jan 2018
Dim Rng As Range
Dim SelText As String
Dim Repeats As Integer
Dim i As Integer
With Selection.Range
SelText = .Text ' copy the selected text
Set Rng = .Sentences(1) ' identify the current sentence
End With
If Len(SelText) Then ' Skip when no text is selected
With Rng
Application.ScreenUpdating = False
Selection.Range.Text = "" ' delete the selected text
Repeats = IIf(IsQuote(.Text), 4, 1)
If Repeats = 4 Then .MoveStart wdCharacter, 1
For i = 1 To Repeats
.Text = SelText & .Text
Next i
Application.ScreenUpdating = True
End With
Else
MsgBox "Please select some text.", _
vbExclamation, "Selection is empty"
End If
End Sub
Private Function IsQuote(Txt As String) As Boolean
' 19 Jan 2018
Dim Quotes
Dim Ch As Long
Dim i As Long
Quotes = Array(34, 147, 148, -24143, -24144)
Ch = Asc(Txt)
' Debug.Print Ch ' read ASCII code of first character
For i = 0 To UBound(Quotes)
If Ch = Quotes(i) Then Exit For
Next i
IsQuote = (i <= UBound(Quotes))
End Function
The approach taken is to identify the first character of the selected sentence using the ASC() function. For a normal quotation mark that would be 34. In my test I came up with -24143 and -24144 (opening and closing). I couldn't identify Chr(145) but found MS stating that curly quotation marks are Chr(147) and Chr(148) respectively. Therefore I added a function that checks all of them. If you enable the line Debug.Print Ch in the function the character code actually found will be printed to the immediate window. You might add more character codes to the array Quotes.
The code itself doesn't consider spaces between words. Perhaps Word will take care of that, and perhaps you don't need it.
You need to supply InStr with the starting position as a first parameter:
If InStr(1, selectedText, punctuation) = 0 Then
Also
Const punctuation As String = " & Chr(145) & "
is going to search for space-ampersand-space-Chr(145)-space-ampersand-space. If you want to search for the smart quote character then use
Const punctuation As String = Chr(145)
Hope that helps.
the following is the function I have for adding the non underlined entry
(to simplify it a bit, there is also a function that does this twice adding 1 string underlined and then the string after it not underlined)
Function Add_Single_Entry(ByVal uEntry As String, ByVal ptime As String, ByVal crntValue As String)
uEntry = UCase( uEntry )
Call add_tList( ptime )
Dim rng1 As Word.Range
' Set Selection position however is appropriate
Set rng1 = Selection.Range
rng1.End = rng1.Start
rng1.Text = uEntry
Selection.Start = rng1.End
End Function
I need to be able to set my starting point to be the next line after the last instance of crntValue but I'm not sure how.
to clarify i would like the code to find the last instance of say "0000Z" (crntValue) in a Word document and then input a string on the next line.
In cases like this, the macro recorder is a good help - just record "goto end, find upwards, insert new line" and adapt the recorded code.
Something like
' goto end of document
Selection.EndKey Unit:=wdStory
With Selection.Find
.Text = crntValue
.Forward = False ' from bottom to top
.Format = False
' adapt to your needs
.MatchCase = False
.MatchWholeWord = False
End With
' Check if the string was found
If Selection.Find.Execute() Then
' goto end of line
Selection.EndKey Unit:=wdLine
' and insert new line
Selection.TypeParagraph
' now you're ready to insert your entry
Else
MsgBox "Sorry, " & crntValue & " was not found.", vbExclamation
End If