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
Related
I have a project that I will likely be doing pretty regularly so I think a macro or vba module would be worth looking into.
The document has several [FORMTEXT] [FORMCHECKBOX] and such and I would like to automate replacing the [FORMTEXT] with {MERGEFIELD formtextname}. I've sone similar with {command} from Crystal to {mergefield } but that was just word replacement not field type. I found things about wdFormtextfield and wdMergeField just not sure how to .find type wdformtext. I assume if I can .find the type I can then .Replace with wdMergeField. I will be looping through the document. Any thoughts?
I might be going the wrong way but this is what I am thinking
Sub Change_FormTextToMergeField()
Application.ScreenUpdating = False
Dim StrFld As String 'change to a wd type for formtext
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "\{*\}"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
i = 1
'add .Replace code to replace wdFieldFormTextInput with wdFieldMergeField
MsgBox .Words.Parent
i = i + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Sample Doc
The following procedure converts all FormFields to MergeFields perserving bookmarks as the Mergefield name
Sub FormFieldToMergeField() '
' A scratch Word macro coded by Charles Kenyon - based on Greg Maxey format
' https://stackoverflow.com/questions/75393869/update-a-formtext-to-a-mergefield-vba
' 2023-02-10
' started with Doug Robbins macro https://answers.microsoft.com/en-us/msoffice/forum/all/convert-formtext-fields-into-bookmarked-content/1f2d7aa2-a335-4667-9955-998d0525ba09
' Converts FormFields to Mail Merge Fields - the Bookmark name becomes the mergefield name
' If no FormField bookmark, then mergefield says Unnamed
'
' DECLARE VARIABLES / CONSTANTS
Dim oRng As range
Dim oFld As Field
Dim strName As String
Dim i As Long
'================================================
' ACTIONS
Application.ScreenUpdating = False
On Error GoTo lbl_Exit
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
Set oRng = .FormFields(i).range
strName = .FormFields(i).Name
If strName = "" Then strName = "Unnamed Field " & i
.FormFields(i).Delete
oRng.Select
Set oFld = .Fields.Add(range:=oRng, Type:=wdFieldMergeField, Text:=strName)
Selection.Collapse wdCollapseStart
Next i
End With
' EXIT PROCEDURE
lbl_Exit:
' CLEAR ERROR HANDLER AND OBJECTS
Application.ScreenUpdating = True
Application.ScreenRefresh
On Error GoTo -1
Set oRng = Nothing
Set oFld = Nothing
Exit Sub
End Sub
If there is no bookmark, the mergefield will be to Unnamed.
Instructions for Installing Macros from Forums or Websites by Word MVP Graham Mayor
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'm new to VBA and would greatly appreciate some help on a problem.
I have long Word documents where I need to apply standard comments to the same set of keywords, but only in selected sections of the document. The following macro worked to find a keyword and apply a comment (from question here https://superuser.com/questions/547710/macro-to-insert-comment-bubbles-in-microsoft-word):
Sub label_items()
'
' label_items Macro
'
'
Do While Selection.Find.Execute("keyword1") = True
ActiveDocument.Comments.Add range:=Selection.range, Text:="comment for keyword 1"
Loop
End Sub
The two modifications are:
1) only apply the comments to user selected text, not the whole document. I tried a "With Selection.Range.Find" approach but I don't think comments can be added this way (??)
2) repeat this for 20+ keywords in the selected text. The keywords aren't totally standard and have names like P_1HAI10, P_1HAI20, P_2HAI60, P_HFS10, etc.
EDIT: I have tried to combine code from similar questions ( Word VBA: finding a set of words and inserting predefined comments and Word macro, storing the current selection (VBA)) but my current attempt (below) only runs for the first keyword and comment and runs over the entire document, not just the text I have highlighted/selected.
Sub label_items()
'
' label_items Macro
'
Dim selbkup As range
Set selbkup = ActiveDocument.range(Selection.range.Start, Selection.range.End)
Set range = selbkup
Do While range.Find.Execute("keyword 1") = True
ActiveDocument.Comments.Add range, "comment for keyword 1"
Loop
Set range = selbkup
Do While range.Find.Execute("keyword 2") = True
ActiveDocument.Comments.Add range, "comment for keyword 2"
Loop
'I would repeat this process for all of my keywords
End Sub
I've combed through previous questions and the Office Dev Center and am stuck. Any help/guidance is greatly appreciated!
It's a matter of adding a loop and a means of Finding the next keyword you're looking for. There are a few suggestions in the code example below, so please adjust it as necessary to fit your requirements.
Option Explicit
Sub label_items()
Dim myDoc As Document
Dim targetRange As Range
Set myDoc = ActiveDocument
Set targetRange = Selection.Range
'--- drop a bookmark to return the cursor to it's original location
Const RETURN_BM = "OrigCursorLoc"
myDoc.Bookmarks.Add Name:=RETURN_BM, Range:=Selection.Range
'--- if nothing is selected, then search the whole document
If Selection.Start = Selection.End Then
Selection.Start = 0
targetRange.Start = 0
targetRange.End = myDoc.Range.End
End If
'--- build list of keywords to search
Dim keywords() As String
keywords = Split("SMS,HTTP,SMTP", ",", , vbTextCompare)
'--- search for all keywords within the user selected range
Dim i As Long
For i = 0 To UBound(keywords)
'--- set the cursor back to the beginning of the
' originally selected range
Selection.GoTo What:=wdGoToBookmark, Name:=RETURN_BM
Do
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Text = keywords(i)
.Execute
If .Found Then
If (Selection.Start < targetRange.End) Then
Selection.Comments.Add Selection.Range, _
Text:="Found the " & keywords(i) & " keyword"
Else
Exit Do
End If
Else
Exit Do
End If
End With
Loop
Next i
'--- set the cursor back to the beginning of the
' originally selected range
Selection.GoTo What:=wdGoToBookmark, Name:=RETURN_BM
End Sub
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
This is a silly question, but can't figure it out.
Straight from the Microsoft Site:
This example finds every instance of the word "Start" in the active document and replaces it with "End." The find operation ignores formatting but matches the case of the text to find ("Start").
Set myRange = ActiveDocument.Range(Start:=0, End:=0)
With myRange.Find
.ClearFormatting
.Text = "Start"
With .Replacement
.ClearFormatting
.Text = "End"
End With
.Execute Replace:=wdReplaceAll, _
Format:=True, MatchCase:=True, _
MatchWholeWord:=True
End With
I need to know how to make it so it only finds the next instance of Start and replace it with End. This will leave all other Ends intact throughout the document.
You should use wdReplaceOne in place of wdReplaceAll.
You should be able to adapt this:
Sub Tester()
Const FIND_WHAT as String = "Start"
Const REPLACE_WITH as String = "End"
Const REPLACE_WHICH As Long = 4 'which instance to replace?
Dim rng As Range, i As Long
i = 0
Set rng = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Text = FIND_WHAT
Do While .Execute(Format:=True, MatchCase:=True, _
MatchWholeWord:=True)
i = i + 1
If i = REPLACE_WHICH Then
'Note - "rng" is now redefined as the found range
' This happens every time Execute returns True
rng.Text = REPLACE_WITH
Exit Do
End If
Loop
End With
End Sub
This discussion has some useful suggestions: Replace only last occurrence of match in a string in VBA. In brief, it's a case of looping through your search string from start until the first instance of the search argument is located and replacing just that.