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 need to clean up text in a MS Word file.
I receive text from a web form like this and then get it as a Word file.
Confirmed: Something
Confirmed: Else
Confirmed: every
Confirmed: time
I would like to get rid of all the "Confirmed" but for the first one, to get something like the following.
Confirmed:
Something
Else
every
time
I count all the words with
Function CountOccurrences(ByVal strToCount As String) As Integer
Dim iCount As Integer
iCount = 0
With ActiveDocument.Content.Find
.Text = strToCount
.Format = False
.Wrap = wdFindStop
Do While .Execute
iCount = iCount + 1
Loop
End With
CountOccurrences = iCount
End Function
I found articles on how to delete just the first one, or the last one, but can't figure out, how to delete all but the first one.
Try this:
Sub tester()
Dim col As Collection, i As Long
Set col = AllOccurrences("Confirmed:")
For i = 2 To col.Count
col(i).Text = vbTab 'replace the text with a tab
Next i
End Sub
'Return a collection with all instances of strToMatch in the activedocument
Function AllOccurrences(ByVal strToMatch As String) As Collection
Dim rv As New Collection, rng As Range
Set rng = ActiveDocument.Range
With rng.Find
.Text = strToMatch
.Format = False
.Wrap = wdFindStop
Do While .Execute
rv.Add ActiveDocument.Range(rng.Start, rng.End)
Loop
End With
Set AllOccurrences = rv
End Function
I'm using a VBA script to try to find the starting number of a paragraph (they are list items not formatted as such - not trying to format, just find the numbers).
1. First Item
2. Second Item
No number - don't include despite 61.5 in paragraph.
25 elephants should not be included
12. Item Twelve, but don't duplicate because of Susie's 35 items
Is there any way to say in VBA "If start of paragraph has 1-2 numbers, return those numbers". In regex, what I'm looking for is ^(\d\+)\.
Here is a working bit of VBA code - haven't figured out how to CREATE the excel file yet, so if you go to test create a blank test.xslx in your temp folder. Of course this may be simple enough that testing isn't necessary.
Sub FindWordCopySentence()
On Error Resume Next
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
' Open Excel File
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xlsx").Sheets("Sheet1")
intRowCount = 1
End If
' Word Document Find
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.ClearFormatting
' Find 1-2 digit number
.Text = "[0-9]{1,2}"
.MatchWildcards = True
.Execute
If .Found Then
' Copy to Excel file
aRange.Expand Unit:=wdSentence
aRange.Copy
aRange.Collapse wdCollapseEnd
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
Set aRange = Nothing
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
End Sub
Thanks!
I would go quite a bit simpler and just check the first few characters of the paragraph:
Option Explicit
Sub test()
Dim para As Paragraph
For Each para In ThisDocument.Paragraphs
With para.Range
If (.Characters(2) = ".") Or (.Characters(3) = ".") Then
If IsNumeric(para.Range.Words(1)) Then
Debug.Print "Do something with paragraph number " & _
para.Range.Words(1) & "."
End If
End If
End With
Next para
End Sub
A more efficient approach, which obviates the need to test every paragraph:
Sub Demo()
Application.ScreenUpdating = False
Dim StrOut As String
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^13[0-9.]{1,}" ' or: .Text = "^13[0-9]{1,}
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
StrOut = StrOut & .Text
' or: MsgBox Split(.Text, vbCr)(1)
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
MsgBox StrOut
End Sub
As coded, the macro returns the entire list strings where there may be multiple levels (e.g. 1.2). Comments show how to find just the first number where there may be multiple levels and how to extract that number for testing (the Find expression includes the preceding paragraph break).
The program is supposed to loop through a directory to find every occurrence of a word from a list that is in another word document and expand selection to the whole question. This program is supposed to allow you to compile a list of test questions from a test bank based on a list of highly relevant key terms. Eventually, once all the relevant questions are selected They would be copied to a new document.
Sub CompareWordList()
'program to loop through Directory to find every occurrence of a word from a list and expand selection to
'the whole question. This program is supposed to allow you to compile a list of test questions from a
'test bank based on a list of highly relevent key terms. Eventually, once all the relevent questions are selected
'They would be copied to a new document
'variables for directory looping
Dim vDirectory As String
Dim oDoc As Document
'generates file path
vDirectory = "D:\school\documents\MGT450\Test_Bank\TB - test\" 'set directory to loop through
vFile = Dir(vDirectory & "*.*") 'file name
'variables for selection
Dim sCheckDoc As String
Dim docRef As Document
'Dim docCurrent As Document
Dim wrdRef As Object
'list of words to look for
sCheckDoc = "D:\testlist.docx"
Set docRef = Documents.Open(sCheckDoc)
'docCurrent.Activate
docRef.Activate
'Directory Loop
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile)
'document activation
oDoc.Activate
SendDocToArray_FindWords (sCheckDoc)
'Havent really worked on this area yet, as been focused on find issue
docRef.Close
'close document modification
oDoc.Close SaveChanges:=False
vFile = Dir
Loop
End Sub
'After every instance of a particular phrase is selected, select question
around said phrase
Function SelectQuestion(Index As Long)
'iniitial declaration
Dim linecount As Integer
Set mydoc = ActiveDocument
Dim oPara As word.Paragraph
'Dim oPara As selection
Dim ListLevelNumber As Integer
Dim holder As Long
'if list type is simple numbering
If selection.Range.ListFormat.ListType = wdListSimpleNumbering Or
wdListBullet Or wdListMixedNumbering Then
'Select Whole Question containing word
With selection
.StartIsActive = False
.Extend Character:=";"
.EndKey
.StartOf (wdLine)
End With
a = selection.MoveUntil(";", wdBackward)
b = selection.MoveDown(wdLine, 2, wdMove)
selection.StartOf (wdLine)
selection.Find.Execute "*^13^13", , , True
'some correction of range- remove last paragraph from selection
ActiveDocument.Range(selection.Start, selection.End - 1).Select
End If
End Function
Function GetParNum(r As Range) As Integer
'determines paragraph number
GetParNum = selection.Range.ListFormat.ListValue
End Function
Sub Test() 'testing function
CountWords
End Sub
Function SendDocToArray_FindWords(name As String) As Variant
'sends a document to an array split by newline
'the document that is send to the array is composed of the words that are
'being searched for.
Dim doc As Document
Set doc = Documents.Open(name)
Dim arr() As String
arr() = Split(doc.Content.Text, Chr(13))
Dim iCount As Integer
Dim targetRng As Range
For Each i In arr()
Dim r As Range
Dim j As Long
Set r = ActiveDocument.Content
With r.Find
'If I pass a variable to FindText it only finds the first instance of the word then
'prematurely exits loop or becomes an infinite loop
'strangely the function is only working when I hardcode the word such as
'FindText:= "International Business"
Do While .Execute(FindText:=i, Forward:=True, Wrap:=wdFindContinue) = True
If r.Find.Found = True Then
j = j + 1
End If
Loop
End With
MsgBox "The Word" & i & " was found " & j & " times."
Next i
MsgBox ("Finished Selecting")
End Function
'testing count words function
Function CountWords(c As String) 'ByRef word As Variant
'counts number of occurences of words in document
Dim r As Range
Dim j As Long
Set r = ActiveDocument.Content
'ResetFRParameters r
With r.Find
'.Wrap = wdFindContinue
Do While .Execute(FindText:=i, Forward:=True) = True
If r.Find.Found = True Then
j = j + 1
End If
Loop
End With
MsgBox "Given word(s) was found " & j & " times."
End Function
'testing count words function
Sub FindText()
Dim MyAR() As String
Dim i As Long
i = 0
selection.HomeKey Unit:=wdStory
selection.Find.Text = "International Business"
' selection.Range.Text
Do While selection.Find.Execute = True
ReDim Preserve MyAR(i)
MyAR(i) = selection
i = i + 1
Loop
If i = 0 Then
MsgBox "No Matches Found"
Exit Sub
End If
For i = LBound(MyAR) To UBound(MyAR)
MsgBox ("# of International Business occurrences " & i)
Next i
End Sub
I used three finds that I was trying to get to work correctly but they do not appear to search the whole document regardless how I use them. I have started wondering if the formatting of my document is to blame. I have attached both an image of the list of terms as well as document to search through.
This is the list of terms to search through
This is the document to search through
My ultimate question is how do I get around this problem and find all instances of the given search term in the document? As of now it either finds the first instance and breaks or becomes an infinite loop.
This is the final that works, although not he prettiest, for others who may be looking for similar code: (pasting it here as messed up the format a bit so youll need to fix those if you use it)
Sub TraversePath()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String '.doc,.docx,.xlsx, etc
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object
types)
Set fldStart = fso.GetFolder("D:\school\documents\MGT450\Test_Bank\TB -
test\") ' Base Directory
Mask = "*.doc"
ListFiles fldStart, Mask
'for each file in folder
'For Each fl In fldStart
' ListFiles fld, Mask
MsgBox ("Fin.")
'Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim runTracker As Integer
runTracker = 0
Dim fl As Object 'File
x = NewDoc 'generate new processed study guide
Dim sCheckDoc As String
Dim docRef As Document
Dim vFile As String
Dim arr() As String
'list of words to look for
sCheckDoc = "D:\testlist.docx"
Set docRef = Documents.Open(sCheckDoc)
docRef.Activate
'send docref to array split by newline
arr() = Split(docRef.Content.Text, Chr(13))
'begin word array loop?
For Each fl In fld.Files
runTracker = runTracker + 1
If fl.name Like Mask Then
'-----------------------------------------------------------------run
program code
vFile = fl.name 'set vFile = current file name
a = Documents.Open(fld.path & "\" & fl.name) 'open current search
file
Documents(vFile).Activate 'activate current search file
For a = 0 To UBound(arr)
'reset selection
selection.HomeKey Unit:=wdStory, Extend:=wdMove
'Inform progress
StatusBar = "Running Find..."
Dim docB As String
docB = Documents("Processed_StudyGuide.docx")
Dim docA As String
docA = Documents(vFile)
Documents(docA).Activate
b = DoFindReplace_Bkmk(arr(a))
'print bookmarked values to new document
StatusBar = "Printing targeted paragraphs..."
PrintBookmarks (bookmarkName)
If b <> 0 Then
'notify how many were inserted
MsgBox ("Complete, inserted: " & b & " bookmarks of " &
arr(a))
End If
Next a
MsgBox ("finished find in: " & vFile)
Documents(vFile).Close (wdDoNotSaveChanges)
'-----------------------------------------------------------------end
code
End If
Next
MsgBox ("Finished all documents")
End Sub
Function SelectQuestion(Index As Long)
'iniitial declaration
Dim linecount As Integer
Dim oPara As word.Paragraph
'Dim oPara As selection
Dim ListLevelNumber As Integer
Dim holder As Long
'if list type is simple numbering
If selection.Range.ListFormat.ListType = wdListSimpleNumbering Or
wdListBullet Or wdListMixedNumbering Then
'Select Whole Question containing word
With selection
.StartIsActive = False
.Extend Character:=";"
.EndKey
.StartOf (wdLine)
End With
a = selection.MoveUntil(";", wdBackward)
b = selection.MoveDown(wdLine, 2, wdMove)
selection.StartOf (wdLine)
selection.Find.Execute "*^13^13", , , True
'some correction of range- remove last paragraph from selection
'ActiveDocument.Range(selection.start, selection.End - 1).Select
End If
End Function
Function GetParNum(r As Range) As Integer
'determines paragraph number
GetParNum = selection.Range.ListFormat.ListValue
End Function
Function NewDoc() As String
'Generate new document and save
a = Documents.Add(, , , True)
ActiveDocument.Content.Delete
ActiveDocument.SaveAs2 ("D:\Processed_StudyGuide")
End Function
Public Function GetName(num As Integer) As String
'names each bookmark
Dim t As String
Dim nameArr() As Variant
nameArr = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l",
"m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "aa",
"bb", "cc", "dd", "ee", "ff", "gg", "hh", "ii", "jj", "kk", "ll", "mm",
"nn", "oo", "pp", "qq", "rr", "ss", "tt", "uu", "vv", "ww", "xx", "yy",
"zz", "aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", "hhh", "iii", "jjj",
"kkk", "lll", "mmm", "nnn", "ooo", "ppp", "qqq", "rrr", "sss", "ttt", "uuu",
"vvv", "www", "xxx", "yyy", "zzz", "aaaa", "bbbb", "cccc", "dddd", "eeee",
"ffff", "gggg", "hhhh", "iiii", "jjjj", "kkkk", "llll", "mmmm", "nnnn",
"oooo", "pppp", "qqqq", "rrrr", "ssss", "tttt", "uuuu", "vvvv", "wwww",
"xxxx", "yyyy", "zzzz", "aaaaa", "bbbbb", "ccccc", "ddddd")
t = nameArr(num)
GetName = t
End Function
Function PrintBookmarks(name As String) 'Add each selection to collection
'Declarations
selection.Collapse
Dim n As Integer
Dim docB As String
docB = Documents("Processed_StudyGuide.docx")
Dim docA As String
docA = ActiveDocument.name
Dim x As Integer
x = ActiveDocument.Bookmarks.Count
Dim a As String
For Each bkmark In Documents(docA).Bookmarks
'If # of bookmarks is greater than 0 select the one at x
If x > 0 Then
With ActiveDocument.Bookmarks(x)
BkMkName = .name
.Select
End With
End If
'selection.Bookmarks(a).Select
SelectQuestion (GetParNum(selection.Range))
selection.Copy
selection.Collapse (wdCollapseEnd)
Documents("Processed_StudyGuide.docx").Activate
selection.MoveEnd
selection.Paste
'reactivate last document
Documents(docA).Activate
x = x - 1
Next
'runs bookmark removal
removebookmarks (docA)
Documents(docB).Activate 'activate processed study guide
' If ActiveDocument.Bookmarks.Count > 0 Then
' FixRepeatedQuestions
' End If
removebookmarks (docB)
ActiveDocument.Save
Documents(docA).Activate
End Function
Sub removebookmarks(name As String)
'removes bookmarks from documents
Dim bkm As Bookmark
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
End Sub
Function DoFindReplace_Bkmk(ByRef FindText As Variant, Optional ReplaceText
As String) As Integer
Dim i As Integer
i = 0
Dim bkmark As String
With selection.Find
'set Find Parameters
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindText
'If replacement text is not supplied replace with targetword to find
If ReplaceText = "" Then
.Replacement.Text = FindText
Else
.Replacement.Text = ReplaceText
End If
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
'Keep going until nothing found
.Execute Replace:=wdReplaceAll
'keep track of how many are replaced
'get bookmark name and add bookmark at location
bookmarkName = GetName(i)
ActiveDocument.Bookmarks.Add name:=bookmarkName, Range:=selection.Range
i = i + 1 'below because array starts at 0
Loop
'Free up some memory
ActiveDocument.UndoClear
End With
'return # of find/replacements
DoFindReplace_Bkmk = i
End Function
For Each i In arr() can't work.
Your Arr() is a string and the Each enumeration only works for objects. You would have to use
For i = 0 to Ubound(Arr)
Next i
Here is the complete code for repetitive searching. Note that the TestCount function prints its output to VBE's Immediate window. If you don't see it, press Ctl+G or select it from the View menu, or change the output to a MsgBox.
Sub TestCount()
' testing procedure
Dim MyPhrase As String
MyPhrase = "International business"
Debug.Print "My phrase was found " & CountWords(MyPhrase) & " times."
End Sub
Function CountWords(Phrase As String) As Integer
' 12 Apr 2017
' return the number of occurences of words in document
Dim Fun As Integer ' Function return value
Dim Rng As Range
Set Rng = ActiveDocument.Content
Do
With Rng.Find
.ClearFormatting
.MatchCase = False
.Text = Phrase
.Execute
If Not .Found Then Exit Do
Fun = Fun + 1
End With
Loop
CountWords = Fun
End Function
For your understanding:-
Find always starts the search at the beginning of the range you set. At the start of the procedure the range is defined as ActiveDocument.Content.
When a match is found, the range is reset to hold only the found phrase, meaning Rng isn't the same as it was before.
The loop now repeats the search with the changed Rng object, again starting at the beginning of that range to the end of the document.
When no more match is found the loop is exited. It's important, not to Wrap because that property instructs Find to continue looking for matches at the beginning of the document when no match is found before its end.
In between, in the place where you now see Fun = Fun + 1, you could execute any code you like - perhaps call a sub there which makes major changes or even copies parts of the document to another document. The important thing is that, after you come back from all that work, the Rng pointer still holds that part of the document from where you want to continue your search.
O hope this will speed you on your way.