VBA Word: Inserting Text Form Fields at a Specified Location - vba

I am new to vba and developing a document that prompts the user to select a variable number of values from a combo box list. After selecting the values, I want to insert them in order onto the document itself as a Text Form Field. Let me show you how I generally am trying to get it to work.
First, the user selects values:
[a]
[b]
[c]
And selects an "OK" button. Then, I am attempting to add these selected values into the word document starting at a bookmark. Value "a" should be inserted followed by a space character followed by a blank Text Form Field, followed by two carriage returns. In the end the result should look something like this:
[bookmark]
[a]'_'[blank_a]'^p'
'^p'
[b]'_'[blank_b]'^p'
'^p'
[c]'_'[blank_c]'^p'
'^p'
Where [bookmark] is an invisible bookmark, '_' is a space, and '^p' is a carriage return. Currently my code is as follows:
Dim myRange As Range
Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Bookmarks("START").Range.Start, _
End:=ActiveDocument.Bookmarks("END").Range.End)
For i = 1 To NUMBER_OF_RESPONSES
Selection.FormFields.Add(myRange, wdFieldFormTextInput).Name = "question_" & i
Selection.FormFields.Add(myRange, wdFieldFormTextInput).Result = "response_" & i
Next i
Naturally, there are no insertions of literal spaces or carriage returns yet as I have not figured out how to do it. The result of this code is as follows:
[START][blank_c][c][blank_b][b][blank_a][a][END]
I would like this order reversed and for there to be the aforementioned formatting inserted. Any pointers on how to go about doing it?

I am not sure if I have missed something, but why not relying on simple paragraphs instead on Bookmarks? Here you have a code doing what you want and any other thing (you can modify the ranges of the paragraphs to perform as complex actions as you wish).
Dim curRange As Range
Dim start_i As Integer
Dim end_i As Integer
Dim NUMBER_OF_RESPONSES As Integer
NUMBER_OF_RESPONSES = 3
start_i = NUMBER_OF_RESPONSES + 1 '0
end_i = 1 'NUMBER_OF_RESPONSES
Set curParagraph = ActiveDocument.Paragraphs.First
curParagraph.Range.Text = "[START]"
i = start_i
Do
If (start_i < end_i) Then
i = i + 1
Else
i = i - 1
End If
Set curParagraph = curParagraph.Range.Paragraphs.Add
curParagraph.Range.Text = "[question_" & i & "][" & "response_" & i & "]"
Loop While (i <> end_i)
Set curParagraph = curParagraph.Range.Paragraphs.Add
curParagraph.Range.Text = "[END]"

Solution
Well now I feel silly for asking the question. The solution was pretty simple.
ActiveDocument.Bookmarks("START").Select
For i = 1 To NUMBER_OF_RESPONSES
Selection.Font.Size = 11
Selection.Font.Bold = True
Selection.FormFields.Add(Range:=Selection.Range, Type:=wdFieldFormTextInput) _
.Name = "question_" & i
Selection.Font.Bold = False
Selection.TypeText Text:=" "
Selection.FormFields.Add(Range:=Selection.Range, Type:=wdFieldFormTextInput) _
.Name = "response_" & i
Selection.TypeParagraph
Selection.TypeParagraph
Next i
So the real issue was placing the cursor in the right location:
ActiveDocument.Bookmarks("START").Select
From there I was able to use Selection to insert the desired FormFields and characters.
This link was pretty helpful.
And if you are reading this because you also are new and trying to learn what to do, check out how to record a macro. It's a good first step. Record the macro, view the code it generated, and use that code to guide your own development. Cool.

Related

VBA - Struggling with worksheet_change. Not working with no error given

I have a sheet in which our wholesale team are to enter L09 Part Codes and quickly see how much we have in stock of that item. The problem is that new starters may struggle to learn these part numbers as they don't follow a simple rule. What I did was create an easier code to remember which is simply: "Cable Type" & "Core Size" & "Cut Length", they also have the option to add "Colour" and "Brand" separated by spaces.
Their entered string may look like 6242y 2.5 100, or maybe 6242y 2.5 100 Grey, etc. and so where to look in my mapped table for what they've written depends on how many terms they put in. As you can see from the attached picture I need to select the correct column to look in for their code, and then offset back a few columns to suggest the correct L09 Part Number.
I hope the context makes a bit of sense and helps with the below code. The idea was for a new starter to enter something simple and it be replaced before their very eyes...
If anyone could help me to correct the following it would be greatly appreciated:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim P, Products, S, Search As Range
Dim Column As String
Dim Counter As Integer
Dim Spaces As Long
'On Error Resume Next
Counter = 0
'For top table only
If Target.Column = 1 And Target.Row < 100 Then
'Count spaces
Spaces = UBound(Split(Target, " "), 1)
Select Case Spaces
Case Is = 2
Column = "M"
Case Is = 3
Column = "O"
Case Is = 4
Column = "Q"
End Select
'When string has spaces
If Spaces <> 0 Then
'Set simple code range
Set Search = Sheets("Cherries").Range(Column & 1 & ":" & Column & 10000)
For Each S In Search
If S = Target Then
Target = S.Offset(0, 3 - 2 * Spaces)
End If
Next S
End If
Set Products = Sheets("Order Entry").Range("A3:A99")
For Each P In Products
If P.Value <> "" Then
Counter = Counter + 1
End If
Next P
Sheets("Order Entry").Rows("3:" & Counter + 11).Hidden = False
Sheets("Order Entry").Rows(Counter + 11 & ":99").Hidden = True
End If
End Sub
Unfortunately I'm not sure which line is erroring as no error message is given.
Thank you for your time.

VBA script to replace cell value and keep formatting

I have the below table in word that I'm trying to write a script to replace the contents of the below cell with a different customer payment (i.e replace the £1,100 with £2,000). Below is a snippet of my script but the when I write back to the cell it loses all the formatting and the numbered list.
How can I keep replace the cell data with very similar data and still keep the formatting?
ps. I've simplified the contents of the cell to make it easier to read, so the code won't apply to exactly that content
DescPlan = Trim(t1.Cell(2, 2).Range.Text)
DescTest = InStr(1, DescPlan, ":")
finalString = Left(DescPlan, DescTest)
t1.Cell(2, 2).Range.Text = Replace(DescPlan, finalString, "Payment by the customer of " + Format(v, "Currency") + " will be due upon completion of items below:")
Not sure if this helps but you are using a table so what works for excel should also work for you.
Sub replace_keep_format()
Dim t1 As Range
Dim sStrng As String, rStrng As String
Dim i As Integer
sStrng = "£1,100"
rStrng = "£2,000"
i = 1
Do Until ThisWorkbook.Sheets(1).Range("a" & i) = ""
Set t1 = ThisWorkbook.Sheets(1).Range("a" & i)
t1 = Replace(Expression:=t1, Find:=sStrng, Replace:=rStrng)
i = i + 1
Loop
End Sub

Add formatted entries from a table in document to the autocorrect library

I’m attempting to add formatted entries from a table in MSWord 2016 document to the autocorrect library (which is stored in normal.dotx as usual for formatted entries).
In the document I have a table containing two columns, the left column has the short text and the right column has the formatted long text for the autocorrect entries.
I have a working macro for storing unformatted text using the line AutoCorrect.Entries.Add Name:=ShortText, Value:=LongText.
I’m trying to modify it to use the AutoCorrect.Entries.AddRichText ShortText, longtext function which should then pick up the font and italics properties in the table.
I tried two methods.
FIRST - testAddRichText1
Here’s the code (removed some of the cosmetics)
Sub testAddRichText1()
Set oDoc = ActiveDocument
For i = 1 To oDoc.Tables(2).Rows.Count
If oDoc.Tables(2).Rows(i).Cells(1).Range.Characters.Count > 1 Then
ShortText = oDoc.Tables(2).Cell(Row:=i, Column:=1)
ShortText = Left(ShortText, Len(ShortText) - 2) 'remove the trailing CR and LF
longtext = oDoc.Tables(2).Cell(Row:=i, Column:=2)
StatusBar = "Adding " & ShortText & " = " & longtext.Text
AutoCorrect.Entries.AddRichText ShortText, longtext
End If
Next i
MsgBox "done"
End Sub
Using this code, there are a number of unprintable characters at the end of the text extracted from the cell, mostly Chr(13)’s. I tried running a cleaner over the string to remove all non-printable characters, but there is something there that just won’t go away and causes a black box at the end of the corrected text when the autocorrect is used. I assume it’s some sort of secret word code that is in the table cell. Attempting to print the ASC value of it returns 13, but deleting it has no effect (just removes characters before the blackbox symbol).
SECOND testAddRichText2
I tried adding italics to my text string in my working model, and then using it with the AddRichText method. AddRichText expects a range and I haven’t been able to convert the text string into a range.
Here is that code
Sub testAddRichText2()
Set oDoc = ActiveDocument
Dim LongTextrng As Range
For i = 1 To oDoc.Tables(2).Rows.Count
If oDoc.Tables(2).Rows(i).Cells(1).Range.Characters.Count > 1 Then
ShortText = oDoc.Tables(2).Cell(Row:=i, Column:=1)
ShortText = Left(ShortText, Len(ShortText) - 2)
longtext = oDoc.Tables(2).Cell(Row:=i, Column:=2).Range
longtext = Left(longtext, Len(longtext) - 2)
LongTextrng.Text = longtext 'Fails
LongTextrng.Italic = True
StatusBar = "Adding " & ShortText & " = " & longtextrng.Text
AutoCorrect.Entries.Add Name:=ShortText, Value:=LongTextrng
End If
Next i
MsgBox "done"
End Sub
Your first example, testAddRichText1, is almost correct. It fails because although you have recognised the need to remove the trailing characters from ShortText you haven't done the same for longText.
To shorten a range you move the end of the range using the MoveEnd method. In this instance you need to move the end of the range back one character to remove the end of cell marker.
In your second example, testAddRichText2, the code fails because you have not assigned the range to the variable, LongTextrng, correctly. When assigning a value to an object variable you need to use the Set command, like this:
Set objVar = object
This did not fail in your first attempt because LongText has not been declared and is therefore assumed to be a Variant.
The code below will work for you:
Sub AddRichTextAutoCorrectEntries()
Dim LongText As Range
Dim oRow As Row
Dim ShortText As String
For Each oRow In ActiveDocument.Tables(2).Rows
If oRow.Cells(1).Range.Characters.Count > 1 Then
ShortText = oRow.Cells(1).Range.Text
ShortText = Left(ShortText, Len(ShortText) - 2)
'assign the range to the variable
Set LongText = oRow.Cells(2).Range
'move the end of the range back by 1 character
LongText.MoveEnd wdCharacter, -1
StatusBar = "Adding " & ShortText & " = " & LongText.Text
AutoCorrect.Entries.AddRichText Name:=ShortText, Range:=LongText
End If
Next oRow
End Sub

Sampling StringName.SubString(p,1) for paragraph formatting character

please try to specifically answer my question and not offer alternative approaches as I have a very specific problem that needs this ad-hoc solution. Thank you very much.
Automatically my code opens Word through VB.NET, opens the document, finds the table, goes to a cell, moves that cells.range.text into a String variable and in a For loop compares character at position p to a String.
I have tried Strings:
"^p", "^013", "U+00B6"
My code:
Dim nextString As String
'For each cell, extract the cell's text.
For p = 17 To word_Rng.Cells.Count
nextString = word_Rng.Cells(p).Range.Text
'For each text, search for structure.
For q = 0 To nextString.Length - 1
If (nextString.Substring(q, 1) = "U+00B6") Then
Exit For
End If
Next
Next
Is the structural data lost when assigning the cells text to a String variable. I have searched for formatting marks like this in VBA successfully in the past.
Assuming that your string contains the character, you can use ChrW to create the appropriate character from the hex value, and check for that:
If nextString.Substring(q, 1) = ChrW(&h00B6) Then
Exit For
End If
UPDATE
Here's a complete example:
Dim nextString = "This is a test " & ChrW(&H00B6) & " for that char"
Console.WriteLine(nextString)
For q = 0 To nextString.Length - 1
If nextString(q) = ChrW(&H00B6) Then
Console.WriteLine("Found it: {0}", q)
End If
Next
This outputs:
This is a test ¶ for that char
Found it: 15

How to extract specific text from a cell?

In this case, I want to extract the beginning text in a cell and leave the remainder intact.
e.g. a series of cells contain:
2nd Unit. Miami
3rd Production Staff. Toronto
1st Ad. San Francisco
I want to break this up without using Text to columns as previous rows are formatted differently and these last few rows are outliers that I want to handle.
I thought Regular Expressions might do it, but that seems a bit complex.
My algorithm idea is:
1. grab the wanted text (what function or custom sub would do that?)
2. Past the text to it's new location
3. Cut the text from the cell, leaving the remaining text.
Seems simple but I'm still wending my way through VBA forest, and at the rate I'm going it's going to end up faster doing it by hand. But this seems like a good opportunity to learn some VBA tricks.
TIA
Update:
I want to take the text up to the ".\ " and move it to a different column, keeping the remainder where it is.
VBA is unnecessary. To get the text after .\ in cell A1: =MID(A1,FIND(".\",A1,1)+2,LEN(A1)) to get the text before .\ in A1: =LEFT(A1,FIND(".\",A1,1)-1).
As additional information, Find returns the placement in the string where .\ appears. It is the equivalent of InStr in VBA. If .\ is not in the cell, it will display #VALUE, because I didn't bother to add error checking.
Since you seem to want to modify the cell text in place, VBA will be required.
Inside a loop that sets cl to the cell to be processed:
str = cl.value
i = Instr(str, ".\")
cl = Trim(Mid$(str, i + 2)) ' assuming you want to exclude the ".\"
cl.Offset(0, 1) Trim(Left$(str, i - 1)) ' Places the original first part one cell to the right
For the sake of anyone who had this same question, here is the fully tested, working code.
Function RE6(strData As String) As String
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "[0-9][0-9][0-9][0-9]B"
RE6 = .test(strData)
End With
Set REMatches = RE.Execute(strData)
If REMatches.Count > 0 Then
RE6 = True
Else
RE6 = False
End If
End Function
Sub territory()
Dim strTest As String, str As String, cl As Range
strTest = ActiveCell.Value
Set cl = ActiveCell
If RE6(strTest) = True Then
str = cl.Value
i = InStr(str, ". ")
cl = Trim(Mid$(str, i + 2))
cl.Offset(0, 1) = Trim(Left(str, i - 1))
cl.Offset(0, 2) = "Instance"
MsgBox RE6(strTest)
End If
End Sub