In Word I am trying to compare the text in a specific cell in a table to a string and struggling.
Sub aMacro()
'
' aMacro Macro
'
'
Dim t As Table
Dim doc As Word.Document
For Each t In ActiveDocument.Tables
Dim Cell As String
Cell = t.Cell(1, 1).Range.Text
If StrComp(Cell, "Name") Then 'This one probably does as well but I haven't tested it yet
Dim Name As String
Dim Amount As String
Dim Value As String
Dim valueInt As Integer
Name = t.Cell(2, 1).Range.Text
Value = t.Cell(2, 3).Range.Text
Amount = t.Cell(2, 4).Range.Text
valueInt = 0
If StrComp(Value, "Monday") Then 'this always activates, regardless of what I compare
valueInt = 5
Selection.TypeText Text:="This is here"
ElseIf StrComp(Value, "Tuesday") Then
valueInt = 4
End If
Selection.TypeText Text:="Name: " + Name 'These all print out with the correct values from the supplied tables
Selection.TypeText Text:="Amount: " + Amount
Selection.TypeText Text:="Value: " + Value
Selection.TypeText Text:=valueInt
End If
Next
End Sub
I can get the values of the cells into variables but I cant seem to do any comparison on these variables. I also can't seem to use the .Value function that a lot of stack overflow posts suggest since it seems to be only available in Excel.
Does anyone happen to know how to compare the text from a table cell to a predefined string? I am using these comparisons to identify which tables contain the required data in a document so if there is a better way that would also be helpful, however I would still need to know how to do the comparisons for later use.
If you are trying to determine if the "Value" is Monday, this would be the syntax:
If Value = "Monday" Then
If you are trying to determine if Value Contains Monday, use Instr
If Instr(Value, "Monday") > 0 Then
Related
I have a lot of large tables in automatically generated word documents and I want to delete columns that have no values in them. They will all have headers, so essentially I need to check the values of rows 2 to the end or just get the whole column in a string and check after the first chr(14) which I understand is the column marker.
Is this possible without looping through the cells, row by row, which appears to be slow, or selecting the column which seems to cause the screen to have issues and the UI freezes, sometimes crashing Word.
What you want to do is perfectly possible but can run into an issue. There is a difference in the number of cells in the selection range reported (and consequently the text to process) depending on whether you use
selection.cells
or
selection.range.cells
The former works as expected, the latter does not.
The code below deletes columns in the way in which you describe and also includes debug.print statements to demonstrate the problem.
I've tested the code on a 5x6 table. Your experience may differ.
Sub DeleteEmptyTableColumns(this_table As Word.Table)
Dim my_cells As Range
Dim my_column As Long
Dim my_text As String
Dim my_last_row As Long
' Assumes that the Table is uniform
my_last_row = this_table.Rows.Count
Application.ScreenUpdating = False
With this_table
For my_column = .Columns.Count To 1 Step -1
DoEvents
Set my_cells = .Range.Document.Range( _
Start:=.Cell(2, my_column).Range.Start, _
End:=.Cell(my_last_row, my_column).Range.End)
' We have to use selection to get the correct text
my_cells.Select
Debug.Print
' Wrong numbers and text
Debug.Print my_cells.Cells.Count
Debug.Print my_cells.Text
' Correct information
Debug.Print Selection.Cells.Count
Debug.Print Selection.Text
' Back to the wrong information
Debug.Print Selection.Range.Cells.Count
Debug.Print Selection.Range.Text
my_text = Selection.Text
' Add other replacments as required.
my_text = Replace(my_text, " ", vbNullString)
my_text = Replace(my_text, vbCrLf, vbNullString)
my_text = Replace(my_text, Chr$(13), vbNullString)
my_text = Replace(my_text, Chr$(7), vbNullString)
If Len(my_text) = 0 Then
this_table.Columns(my_column).Delete
End If
Next
End With
Application.ScreenUpdating = True
End Sub
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.
I have a Word VBA script that adds some headings and a table to the current selection. I'm now trying to get it to pull information from the table below and put it under the correct heading. The end goal is to take the information out of table format for better navigation, because Word's outline doesn't recognize headings inside tables.
I've only gotten as far as putting table content into string variables before I get run-time error 5941: The requested member of the collection does not exist. The debugger goes to this line:
strChildren = rngSource.Tables(1).Cell(Row:=2, Column:=4).Range.Text
The table has far more than two rows and four columns. To make sure the member of the collection existed, I used another script to give me the row and column for the current selection:
Sub CellRowColumn()
'For the current selection, shows a message box with the cell row and column.
With Selection.Cells(1)
MsgBox ("Column = " & .ColumnIndex & vbCr & "Row = " & .RowIndex)
End With
End Sub
I ran this one in the cell I want to copy from, and it does show Row 2 & Column 4.
This is the code I'm using:
Sub ElementHeadings()
'With the current selection, adds the headings for each element in the
'Elements and Attribute List (Description, Parent(s), and Child(ren)) and
'a table for attributes, with 3 columns, headed "Attribute
'Name", "Attribute Required?" and "Attribute Content")
Dim rngSelection As Range
Dim rngTable As Range
Dim rngHeading As Range
Dim rngSource As Range
Dim strCaption As String
Dim lngCaptionLength As Long
Dim strDescr As String
Dim strParents As String
Dim strChildren As String
Dim strVol As String
Dim strUsedIn As String
Set rngSelection = Selection.Range
'msgBox (rngSelection.Text)
With rngSelection
.InsertAfter ("Description")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertAfter ("Parent(s)")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertAfter ("Child(ren)")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertParagraphAfter
.InsertParagraphAfter
Set rngTable = .Paragraphs(5).Range
.InsertAfter ("Volume & Chapter")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertAfter ("Used In")
.Expand unit:=wdParagraph
.Style = "Heading 4"
'MsgBox (rngSelection.Text)
End With
ActiveDocument.Tables.Add Range:=rngTable, NumRows:=3, NumColumns:=3
With rngTable
.Tables(1).Cell(1, 1).Range.Text = "Attribute Name"
.Tables(1).Cell(1, 2).Range.Text = "Attribute Required?"
.Tables(1).Cell(1, 3).Range.Text = "Attribute Content"
.Select
GenericMacros.TableFormat
.Move unit:=wdParagraph, Count:=-1
.Select
End With
rngSelection.Select
Set rngHeading = Selection.GoTo(what:=wdGoToHeading, Which:=wdGoToPrevious)
rngHeading.Expand unit:=wdParagraph
'MsgBox (rngHeading.Text)
rngTable.Select
strCaption = rngHeading.Text
lngCaptionLength = Len(strCaption)
strCaption = Left(strCaption, lngCaptionLength - 1)
Selection.InsertCaption Label:=wdCaptionTable, Title:=". <" _
& strCaption & "> Attribute Table"
rngSelection.Select
Set rngSource = Selection.GoTo(what:=wdGoToTable, Which:=wdGoToNext)
rngSource.Expand unit:=wdTable
strDescr = rngSource.Tables(1).Cell(Row:=2, Column:=2).Range.Text
strParents = rngSource.Tables(1).Cell(Row:=2, Column:=3).Range.Text
strChildren = rngSource.Tables(1).Cell(Row:=2, Column:=4).Range.Text
strVol = rngSource.Tables(1).Cell(Row:=2, Column:=8).Range.Text
strUsedIn = rngSource.Tables(1).Cell(Row:=2, Column:=9).Range.Text
MsgBox ("strDescr = " & strDescr & vbCr & "strParents = " & strParents & _
vbCr & "strChildren =" & strChildren & vbCr & "str3001Vol = " _
& str3001Vol & "strUsedIn = " & strUsedIn)
End Sub
(This may end up being a SuperUser question rather than a Stack Overflow question, if the problem is the document rather than my code. Previously, I was having trouble copying and pasting from the table (copying text but not getting the option to paste it above), but that's no longer happening. So if there's not an apparent issue with the code, maybe it's document corruption or some other Word weirdness.)
Update: My source range contained the table I had just created, rather than the one I wanted to pull from, so I fixed the Selection.Goto that was creating rngSource.
Good that you were able to track down where your code was failing. Working with the Selection object tends to be unreliable as it may not be where you're assuming (or where it was) when you wrote the code.
It's much better to work with Word's objects as whenever possible. For example, when you create a table, Dim a variable, then assign to it when you create the table. That gives you a "handle" on the table, no matter what kind of editing takes place before it, later:
Dim tbl as Word.Table
Set tbl = ActiveDocument.Tables.Add(Range:=rngTable, NumRows:=3, NumColumns:=3).
tbl.Cell(1,1).Range.Text = "Attribute Name"
'and so on...
To pick up an existing table you need to be able to identify it. If you're certain of the position, then:
Set tbl = ActiveDocument.Tables([index value])
If this is a "template" kind of document that you set up and re-use you can bookmark the table (select the table and insert a bookmark, or click in the first cell and insert a bookmark), then:
Set tbl = ActiveDocument.Bookmarks("BookmarkName").Range.Tables(1)
In a similar vein, you can replace this:
rngHeading.Expand unit:=wdParagraph
with the following if you want to work with the paragraph, explicitly:
Dim para as Word.Paragraph
Set para = rngHeading.Paragraphs(1)
It may also help you to know you can "collapse" a Range (similar to pressing the Arrow key with a selection) to its start or end point. This is useful if you want to add something, format it, then add something else that should have different formatting... (as an alternative to using InsertAfter consecutively then going back and formatting things differently).
I got something like OP, and after running below code:
Dim tbl As Word.Table: Set tbl = doc.Tables(2)
MsgBox tbl.Cell(1, 1).Range.Text
Which works on the idea that each table should have at least one cell in it,
did notice that I was accessing the wrong table too ;-)
So, you may use that first to get sure.
I'm working on a macro to loop through a series of strings (a1, a2, a3) and replace them with a series of corresponding values (b1, b2, b3). I've created an array to store the strings to match:
Dim search_strings(1 To 2) As String
search_strings(1) = "match1"
search_strings(2) = "match2"
I can loop through this array with a For Each loop. But I can't figure out how to store and reference the corresponding replacement text. I know that I need some sort of key/value pair. I've tried using a dictionary, like this:
Dim dict As New Scripting.Dictionary
dict.Add "match", "replace"
But for that to work, I need to reference Microsoft Scripting Runtime, which isn't available on Mac OS X. (Currently, I get this error: Compile error: User-defined type not defined.)
Is there another way?
Here's the full code:
Sub MyMacro()
' Initialize variables
Dim search_strings(1 To 2) As String
Dim this_search_string As Variant
Dim myRange As Range
Dim Reply As Integer
' Define strings to match
search_strings(1) = "match1"
search_strings(2) = "match2"
' Run a search for each string in the array of strings to match
For Each this_search_string In search_strings
' Define the search range to be the whole document
Set myRange = ActiveDocument.Content
' Set the Find parameters
myRange.Find.ClearFormatting
myRange.Find.MatchWildcards = True
' Loop through each match in the document
Dim cached As Long
cached = myRange.End
Do While myRange.Find.Execute(this_search_string)
myRange.Select
' Prompt the user to replace the match
Reply = MsgBox("Replace '" & myRange.Find.Text & "'?", vbYesNoCancel)
If Reply = 6 Then ' "Yes" clicked
myRange.Text = "replacement"
ElseIf Reply = 2 Then ' "Cancel" clicked
Exit Do
End If
myRange.Start = myRange.Start + Len(myRange.Find.Text)
myRange.End = cached
Loop
Next this_search_string
End Sub
This may be completely off and I may look like a fool but have you tried using a two dimensional array so you can store the values with their replacements in the two dimensional array. Then you can loop through to get the replacement values. That is just an idea I had, it could be way off.
Sub MyMacro()
' Initialize variables
Dim search_strings(1 To 2, 1 to 2) As String
Dim this_search_string As Variant
Dim myRange As Range
Dim Reply As Integer
' Define strings to match
search_strings(1, 1) = "match1"
search_strings(2, 1) = "match2"
search_strings(1, 2) = "result"
search_strings(2, 2) = "result"
' Run a search for each string in the array of strings to match
For Each this_search_string In search_strings
' Define the search range to be the whole document
Set myRange = ActiveDocument.Content
' Set the Find parameters
myRange.Find.ClearFormatting
myRange.Find.MatchWildcards = True
' Loop through each match in the document
Dim cached As Long
cached = myRange.End
Do While myRange.Find.Execute(this_search_string)
myRange.Select
' Prompt the user to replace the match
Reply = MsgBox("Replace '" & myRange.Find.Text & "'?", vbYesNoCancel)
If Reply = 6 Then ' "Yes" clicked
myRange.Text = search_strings(1, 2)
ElseIf Reply = 2 Then ' "Cancel" clicked
Exit Do
End If
myRange.Start = myRange.Start + Len(myRange.Find.Text)
myRange.End = cached
Loop
Next this_search_string
End Sub
Im really not sure if this is what you are looking for so I apologize if I am wasting your time.
I have a couple of tables and want to replace column 2 or column 5 (if it exists) with check boxes.
If there is an asterisk in the cell, I want the check box checked = True.
If there's no asterisk, the cell will only be a unchecked check box. These check boxes are from the developer tab, under controls, legacy forms.
I researched but failed:
replacing an asterisk with a check box (checked)
limiting it to a specific column (see image)
replacing a blank cell with a check box (unchecked)
limiting the action to a specific column (2 and 5 (if it exists))
Dim oCell As Cell
Dim oRow As Row
For Each oRow In Selection.Tables(1).Rows
For Each oCell In oRow.Cells 'this won't work specifically with my example, needs to be a little more specific
If oCell.Range.Text = "*" Then
MsgBox oCell.RowIndex & ", " & oCell.ColumnIndex & " check it!"
'I don't how to put in a check box here
End If
Next oCell
Next oRow
'I want to combine the top code and code below...right?
'do for each cell in column 2
With ActiveDocument.FormFields.Add(Range:=ActiveDocument.Selection, Type:=wdFieldFormCheckBox)
If cellvalue = "" Then 'just verbal logic here
.CheckBox.Value = False
End If
If cellvalue = "*" Then 'just verbal logic here
.checkbox.Value = True
End If
End With
Here's how I would do this:
Dim objDoc As Document
Dim oCell As Cell
Dim oCol As Column
Dim objTable As Table
Dim bFlag As Boolean
Set objDoc = ActiveDocument
Set objTable = Selection.Tables(1)
'This may or may not be necessary, but I think it's a good idea.
'Tables with spans can not be accessed via the spanned object.
'Helper function below.
If IsColumnAccessible(objTable, 2) Then
For Each oCell In objTable.Columns(2).Cells
'This is the easiest way to check for an asterisk,
'but it assumes you have decent control over your
'content. This checks for an asterisk anywhere in the
'cell. If you need to be more specific, keep in mind
'that the cell will contain a paragraph return as well,
'at a minimum.
bFlag = (InStr(oCell.Range.Text, "*") > 0)
'Delete the content of the cell; again, this assumes
'the only options are blank or asterisk.
oCell.Range.Delete
objDoc.FormFields.Add Range:=oCell.Range, Type:=wdFieldFormCheckBox
'Set the value. I found some weird results doing this
'any other way (such as setting the form field to a variable).
'This worked, though.
If bFlag Then
oCell.Range.FormFields(1).CheckBox.Value = True
End If
Next oCell
End If
'Then do the same for column 5.
Public Function IsColumnAccessible(ByRef objTable As Table, iColumn As Integer) As Boolean
Dim objCol As Column
'This is a little helper function that returns false if
'the column can't be accessed. If you know you won't have
'any spans, you can probably skip this.
On Error GoTo IsNotAccessible
IsColumnAccessible = True
Set objCol = objTable.Columns(iColumn)
Exit Function
IsNotAccessible:
IsColumnAccessible = False
End Function