I need to count the number of occurrences of a specific style, within a column of a table. My program finds the number of occurrences within the whole document instead of only in the selection.
Sub Find()
Selection.Tables(1).Columns(1).Select
With Selection.Find
.Style = "Style2"
iCount = 0
While .Execute
iCount = iCount + 1
Wend
MsgBox (iCount)
End With
End Sub
Performing Find inside a table is a tricky proposition as Find has a nasty tendancy to "bounce" inside of a cell. When I tested your code, having no information on how the style is applied in the table cells, the macro went into a loop and didn't stop until I forced it to. So I was a bit surprised that your code worked at all...
The problem with doing find on a column is that, in the underlying structures of the document a column is not a contiguous set of characters, the way it appears on-screen. The Word table information runs top-to-bottom in the cell, left-to-right across a row, then to the next row and repeat. The column selection is an illusion maintained by the Word application. So macro code basing on Selection or Range can't follow the usual rules that apply.
The following worked for me. In essence, it searches inside the entire table, but when it hits a cell not in the specified column the target range is moved to the next cell in the column and the search is run again. Only the "hits" inside cells in the column are counted.
Sub FindStyleInstanceInTableColumn()
Dim iCount As Long, iCellCount As Long, iCounter As Long
Dim cel As word.Cell
Dim col As word.Column
Dim rngFind As word.Range, rngCel As word.Range
Dim bFound As Boolean
Set col = Selection.Tables(1).Columns(1)
iCount = 0
iCellCount = col.Cells.Count
iCounter = 1
Set rngCel = col.Cells(iCounter).Range
Set rngFind = rngCel.Duplicate
'Don't include end-of-cell marker
rngFind.MoveEnd wdCharacter, -1
rngFind.Select 'For debugging
With rngFind.Find
.Style = "Style2"
bFound = .Execute(wrap:=wdFindStop)
Do
rngFind.Select 'For debugging
If bFound Then
'If the found range is within a column cell
'then increase the counter
If rngFind.InRange(rngCel) Then
iCount = iCount + 1
'If the found range is not in a column cell
'then the style wasn't found in the cell so
'go to the next cell
ElseIf iCounter < iCellCount Then
iCounter = iCounter + 1
Set rngCel = col.Cells(iCounter).Range
rngFind.Start = rngCel.Start
rngFind.End = rngCel.Start
End If
rngFind.Collapse wdCollapseEnd
End If
bFound = .Execute(Format:=True, wrap:=wdFindStop)
Loop Until iCounter = iCellCount And Not bFound
End With
MsgBox (iCount)
End Sub
EDIT: Adjusted the code to take into account no hits in first cell and hits in the last cell of the column. The difference is to make sure the starting point for rngFind is in the same cell as rngCel.
Related
I have a table where all cells have Cell.WordWrap set to true. Some of them have text longer than cell width so it's wrapped. I need to find them (with longer text) and set them Cell.FitText = True, but can't figure how.
I tried to read row/cell .height. But it does not return real row/cell height but minimum height regardless how Cell.HeightRule is set.
Thanks for your tips!
One way to determine whether the content of a cell wraps is to compare the line numbering of the start and end of the cell content, as demonstrated in the following code example.
The Word object model provides the Information property, which has numerous enumeration members, including wdFirstCharacterLineNumber.
Each cell in a table is checked in a loop. After determining the line number of the first character in the cell, the Range is collapsed to its end-point (which is the beginning of the next cell), then moved back one character (putting it in the original cell) and the line number of the last character in the cell is checked.
If the second is greater than the first, the cell is added to an array. (Note: possibly, you could process the cell directly. But if this could affect other cells, better to add them all to an array, first, then process the array.)
Finally, the array is looped and each cell formatted with FitText = True
Sub ChangeCellWrapForLongLinesOfText()
Dim tbl As Word.Table
Dim cel As Word.Cell
Dim rngCel As Word.Range
Dim multiLineCells() As Word.Cell
Dim firstLine As Long
Dim lastLine As Long
Dim i As Long, x As Long
Set tbl = ActiveDocument.Tables(1)
For Each cel In tbl.Range.Cells
Set rngCel = cel.Range
firstLine = rngCel.Information(wdFirstCharacterLineNumber)
rngCel.Collapse wdCollapseEnd
rngCel.MoveEnd wdCharacter, -1
lastLine = rngCel.Information(wdFirstCharacterLineNumber)
If lastLine > firstLine Then
ReDim Preserve multiLineCells(i)
Set multiLineCells(i) = cel
i = i + 1
End If
Next
'Debug.Print i, UBound(multiLineCells())
For x = LBound(multiLineCells()) To UBound(multiLineCells())
'Debug.Print multiLineCells(x).Range.Text
multiLineCells(x).FitText = True
Next
End Sub
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!
In Word I have a document with multiple tables full of data. Hidden inside these cells (out of view but the data is there) is the Hex code of the color I want to shade the cells. I chose the hex value just because it's relatively short and it's a unique bit of text that won't be confused with the rest of the text in the cell.
I've found some code online to modify but I can't seem to make it work. It doesn't give any errors, just nothing happens. I feel like the problem is in searching the tables for the text value but I've spent hours on this and I think I've confused myself now!
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
If oRng = "CCFFCC" Then
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
End If
If oRng = "FFFF99" Then
oCel.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
Next
Next
End Sub
Thanks!
Edit:
I've also tried this code wit the same result of nothing happening:
Sub EachCellText()
Dim oCell As Word.Cell
Dim strCellString As String
For Each oCell In ActiveDocument.Tables(1).Range.Cells
strCellString = Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 1)
If strCellString = "CCFFFF" Then
oCell.Shading.BackgroundPatternColor = wdColorLightGreen
If strCellString = "CCFFCC" Then
oCell.Shading.BackgroundPatternColor = wdColorLightYellow
If strCellString = "FFFF99" Then
oCell.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
End If
End If
Next
End Sub
Your Code is getting stuck nowhere. But you are checking the whole Cell Value against the Hex code, and this will not work since "blablabla FFFFFF" is never equal to "FFFFFF". So you have to check if the Hex code is in the Cell value:
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
Dim cellvalue As String
'check if Colorcode is in cell
If InStr(oRng, "CCFFCC") Then
'Set Cell color
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
'Remove Colorcode from Cell
cellvalue = Replace(oRng, "CCFFCC", "")
'load new value into cell
oRng = cellvalue
End If
Next
Next
End Sub
Now you just have to add all the colors you want to use (I would prefer a Select Case statement) and the code should work fine
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
I looked up some examples, but I cannot quite understand how the Range object works. I am trying to loop through each of my headings (of level 4) and have a nested loop that looks through all the tables in between the headings. I cannot figure out how to set that specific range, so any help will be greatly appreciated.
Dim myHeadings As Variant
myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
For iCount = LBound(myHeadings) To UBound(myHeadings)
level = getLevel(CStr(myHeadings(iCount)))
If level = 4 Then
'This is where I want to set a range between myHeadings(iCount) to myHeadings(iCount+1)
set aRange = ??
End If
Next iCount
You are on the right track here. The myHeadings variable you have simply gives a list of the strings of the Level 4 Headings in the document. What you need to do is then search the document for those strings to get the range of the Level 4 Headings.
Once you have the range of each of the headings you can check for the tables in the range between these headings. I've modified your code slightly to do this. Also note its good practice to put Option Explicit at the top of your module to ensure all variables are declared.
My code will tell you how many tables are between each of the Level 4 headings. NOTE: It does not check between the last heading and the end of the document, I'll leave that up to you ;)
Sub DoMyHeadings()
Dim iCount As Integer, iL4Count As Integer, Level As Integer, itabCount As Integer
Dim myHeadings As Variant, tbl As Table
Dim Level4Heading() As Range, rTableRange As Range
myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
'We want to move to the start of the document so we can loop through the headings
Selection.HomeKey Unit:=wdStory
For iCount = LBound(myHeadings) To UBound(myHeadings)
Level = getLevel(CStr(myHeadings(iCount)))
If Level = 4 Then
'We can now search the document to find the ranges of the level 4 headings
With Selection.Find
.ClearFormatting 'Always clear find formatting
.Style = ActiveDocument.Styles("Heading 4") 'Set the heading style
.Text = VBA.Trim$(myHeadings(iCount)) 'This is the heading text (trim to remove spaces)
.Replacement.Text = "" 'We are not replacing the text
.Forward = True 'Move forward so we can each consecutive heading
.Wrap = wdFindContinue 'Continue to the next find
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
'Just make sure the text matches (it should be I have a habit of double checking
If Selection.Text = VBA.Trim$(myHeadings(iCount)) Then
iL4Count = iL4Count + 1 'Keep a counter for the L4 headings for redim
ReDim Preserve Level4Heading(1 To iL4Count) 'Redim the array keeping existing values
Set Level4Heading(iL4Count) = Selection.Range 'Set the range you've just picked up to the array
End If
End If
Next iCount
'Now we want to loop through all the Level4 Heading Ranges
For iCount = LBound(Level4Heading) To UBound(Level4Heading) - 1
'Reset the table counter
itabCount = 0
'Use the start of the current heading and next heading to get the range in between which will contain the tables
Set rTableRange = ActiveDocument.Range(Level4Heading(iCount).Start, Level4Heading(iCount + 1).Start)
'Now you have set the range in the document between the headings you can loop through
For Each tbl In rTableRange.Tables
'This is where you can work your table magic
itabCount = itabCount + 1
Next tbl
'Display the number of tables
MsgBox "You have " & itabCount & " table(s) between heading " & Level4Heading(iCount).Text & " And " & Level4Heading(iCount + 1).Text
Next iCount
End Sub
You could jump from one heading to the next using Goto. See below how to loop through level 4 headings.
Dim heading As Range
Set heading = ActiveDocument.Range(start:=0, End:=0)
Do ' Loop through headings
Dim current As Long
current = heading.start
Set heading = heading.GoTo(What:=wdGoToHeading, Which:=wdGoToNext)
If heading.start = current Then
' We haven't moved because there are no more headings
Exit Do
End If
If heading.Paragraphs(1).OutlineLevel = wdOutlineLevel4 Then
' Now this is a level 4 heading. Let's do something with it.
' heading.Expand Unit:=wdParagraph
' Debug.Print heading.Text
End If
Loop
Don't look specifically for "Heading 4" because,
one may use non built-in styles,
it would not work with international versions of Word.
Check the wdOutlineLevel4 instead.
Now, to get the range for the whole level 4, here is a little known trick:
Dim rTableRange as Range
' rTableRange will encompass the region under the current/preceding heading
Set rTableRange = heading.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
This will work better for the last heading 4 in the document or the last one below a heading 3.