I have a word document that is being generated from my program and currently have a macro that replaces <BR/> tags with a newline. This signifies the start of a new section in the table so I also wanted to add a border to the top of that row where the <BR/> tag occurs. My current code is:
With ActiveDocument.Content.Find
.Text = "<BR/>"
.Forward = True
While .Execute
.Parent.Text = Chr(10)
.Parent.Collapse wdCollapseEnd
Wend
End With
How could I get the entire row in the table where <BR/> occurs and then add a border to it?
My attempt so far was to add at end of the while loop after Collapse:
With .Parent.Row.Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
But that does not do anything (also no error). I do not think I am grabbing the row correctly but I can not find any other way of doing it. Thanks.
EDIT:
I am now thinking maybe I should do a separate check before the newline part. So adding a for loop to loop through all table rows, check if <BR/> exists and if it does add a border to the top of the row.
I am not used to vba in word, usually use excel so think I might be mixing the two. Here is what I have got so far:
Dim oTbl As Table
Set oTbl = ActiveDocument.Tables(1)
For Each oRow In oTbl.Rows
If InStr(1, oRow.Cell(1, 1), "<BR/>", vbBinaryCompare) > 0 Then
oRow.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
End If
Next
Ok I got it working using the for loop way. My final code was:
Dim oTbl As Table
Dim oRow As Row
For Each oTbl In ActiveDocument.Tables
For Each oRow In oTbl.Rows
If InStr(1, oRow.Cells(1).Range.Text, "<BR/>", vbBinaryCompare) > 0 Then
oRow.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
End If
Next
Next
So this loops through all tables in the document and then all the rows in each table adding a border line above each row that contains the <BR/> tag in its first cell (which signifies a new section). I do all this before the next part of the code which replaces the <BR/> tag with the new line character.
Hopefully this helps someone in the future.
Related
I have a Word application which generates a document containing a boatload of Word tables and nothing else. In the end, I want a single table containing hundreds of rows which could potentially spread over a couple hundred pages. However, it is far easier to generate this document a table at a time with some sort of a break, be it a page break or continuous section break, between tables.
While the tables are numerous, they all contain multiple rows with two columns taking up 20% and 80% of the width. Row 1 always has both cells merged. I've found that having merged cells impacts performance such that some operations, here the width setting, sporadically fail. Adding a DoEvents or delay between iterations helps somewhat, but the best thing I've found for this is to do the cell merge for all the tables after they have been initially built.
Now that the document containing all the tables has been generated, what's a "better" way to remove the section breaks such that all the tables become fused together as one?
This has worked for me, first to attempt removing the breaks with something like this:
With ActiveDocument.Content.Find
.ClearAllFuzzyOptions
.ClearFormatting
.Text = "^m" ' for page breaks
' .Text = "^b" ' when searching for continuous section breaks
.Replacement.Text = ""
.Execute Replace:=WdReplace.wdReplaceAll
End With
Interestingly, when a continuous section break is used, this code fragment only removes the very last occurrence, as does the replace facility in the Word ribbon. When a page break is used, all page breaks are removed, however this leaves two stray paragraphs between tables. These can be cleaned up with something like the following:
For i = ActiveDocument.Paragraphs.Count To 1 Step -1
If Not ActiveDocument.Paragraphs(i).Range.Information(wdWithInTable) Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next i
This works but is understandably rather slow. (There are some 4000 paragraphs in total, 50 of which are candidates for removal)
In the end, using page breaks plus cleanup works but is very slow. Ideally, the first code fragment should work with continuous section breaks, which should require no downstream cleanup. Suggestions?
This is using MS Office 2016.
This program replicates the problem on my system.
Public Sub test()
Dim Word As Word.Application: Set Word = New Word.Application
Dim i As Integer, j As Integer, k As Integer
Word.Visible = True
Word.Activate
Word.ScreenUpdating = True
Word.Documents.Add
Dim c As Integer
Dim t As Integer: t = 0
Dim myrange As Word.Range: Set myrange = ActiveDocument.Content
myrange.Collapse Direction:=wdCollapseEnd
For j = 0 To 25
' depending on a blank row, add either a single row or rows for all the countries' answers
t = t + 1
ActiveDocument.Tables.Add Range:=myrange, NumRows:=25 + 2, NumColumns:=2
With ActiveDocument.Tables(t)
.rows(1).Cells(1).Range.Text = "Header " & j
.Borders.Enable = True
.Columns(1).PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidthType = wdPreferredWidthPercent
.Columns(2).PreferredWidth = 80
End With
For i = 0 To 25
With ActiveDocument.Tables(t).rows(i + 2)
.Cells(1).Range.Text = "Text " & i & " " & j
.Cells(2).Range.Text = "More Text " & i & " " & j
End With
DoEvents
Next i
Set myrange = ActiveDocument.Content
myrange.Collapse Direction:=wdCollapseEnd
myrange.InsertBreak Type:=wdSectionBreakContinuous
Next j
' fix up row 1 for all tables
For i = 1 To ActiveDocument.Tables.Count
With ActiveDocument.Tables(i)
.rows(1).Cells.Merge
.rows(1).Cells(1).Range.Style = "Heading 3"
.rows(1).Cells(1).Shading.BackgroundPatternColor = wdColorGray25
End With
DoEvents
Next i
With ActiveDocument.Content.Find
.ClearAllFuzzyOptions
.ClearFormatting
.Text = "^b"
.Replacement.Text = ""
.Execute Replace:=WdReplace.wdReplaceAll
End With
For i = Word.ActiveDocument.Paragraphs.Count To 1 Step -1
If Not Word.ActiveDocument.Paragraphs(i).Range.Information(wdWithInTable) Then
Word.ActiveDocument.Paragraphs(i).Range.Delete
End If
Next i
End Sub
I'd like to find several strings within Word document and for each string found, I like to print (debug.print for example) the whole row content where the string is found, not the paragraph.
How can I do this? Thanks
Sub FindStrings
Dim StringsArr (1 to 3)
StringsArr = Array("string1","string2","string3")
For i=1 to 3
With
Selection.Find
.ClearFormatting
.Text = Strings(i)
Debug.Print CurrentRow 'here I need help
End With
Next
End Sub
The term Row in Word is used only in the context of a table. I assume the term you mean is Line, as in a line of text.
The Word object model has no concept of "line" (or "page") due to the dynamic layout algorithm: anything the user does, even changing the printer, could change where a line or a page breaks over. Since these things are dynamic, there's no object.
The only context where "line" can be used is in connection with a Selection. For example, it's possible to extend a Selection to the start and/or end of a line. Incorporating this into the code in the question it would look something like:
Sub FindStrings()
Dim StringsArr As Variant
Dim bFound As Boolean
Dim rng As Word.Range
Set rng = ActiveDocument.content
StringsArr = Array("string1", "string2", "string3")
For i = LBound(StringsArr) To UBound(StringsArr)
With rng.Find
.ClearFormatting
.Text = StringsArr(i)
.Wrap = wdFindStop
bFound = .Execute
'extend the selection to the start and end of the current line
Do While bFound
rng.Select
Selection.MoveStart wdLine, -1
Selection.MoveEnd wdLine, 1
Debug.Print Selection.Text
rng.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
Set rng = ActiveDocument.content
Next
End Sub
Notes
Since it's easier to control when having to loop numerous times, a Range object is used as the basic search object, rather than Selection. The found Range is only selected for the purpose of getting the entire line as these "Move" methods for lines only work on a Selection.
Before the loop can continue, the Range (or, if we were working with a selection, the selection) needs to be "collapsed" so that the code does not search and find the same instance of the search term, again. (This is also the reason for Wrap = wdFindStop).
I need to create a macros which removes whitespaces and indent before all paragraphs in the active MS Word document. I've tried following:
For Each p In ActiveDocument.Paragraphs
p.Range.Text = Trim(p.range.Text)
Next p
which sets macros into eternal loop. If I try to assign string literal to the paragraphs, vba always creates only 1 paragraph:
For Each p In ActiveDocument.Paragraphs
p.Range.Text = "test"
Next p
I think I have a general misconception about paragraph object. I would appreciate any enlightment on the subject.
The reason the code in the question is looping is because replacing one paragraph with the processed (trimmed) text is changing the paragraphs collection. So the code will continually process the same paragraph at some point.
This is normal behavior with objects that are getting deleted and recreated "behind the scenes". The way to work around it is to loop the collection from the end to the front:
For i = ActiveDocument.Paragraphs.Count To 1 Step -1
Set p = ActiveDocument.Paragraphs(i)
p.Range.Text = Trim(p.Range.Text)
Next
That said, if the paragraphs in the document contain any formatting this will be lost. String processing does not retain formatting.
An alternative would be to check the first character of each paragraph for the kinds of characters you consider to be "white space". If present, extend the range until no more of these characters are detected, and delete. That will leave the formatting intact. (Since this does not change the entire paragraph a "normal" loop works.)
Sub TestTrimParas()
Dim p As Word.Paragraph
Dim i As Long
Dim rng As Word.Range
For Each p In ActiveDocument.Paragraphs
Set rng = p.Range.Characters.First
'Test for a space or TAB character
If rng.Text = " " Or rng.Text = Chr(9) Then
i = rng.MoveEndWhile(" " + Chr(9))
Debug.Print i
rng.Delete
End If
Next p
End Sub
You could, of course, do this in a fraction of the time without a loop, using nothing fancier than Find/Replace. For example:
Find = ^p^w
Replace = ^p
and
Find = ^w^p
Replace = ^p
As a macro this becomes:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
.InsertBefore vbCr
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
.Text = "^p^w"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^w^p"
.Execute Replace:=wdReplaceAll
End With
.Characters.First.Text = vbNullString
End With
Application.ScreenUpdating = True
End Sub
Note also that trimming text the way you're doing is liable to destroy all intra-paragraph formatting, cross-reference fields, and the like; it also won't change indents. Indents can be removed by selecting the entire document and changing the paragraph format; better still, modify the underlying Styles (assuming they've been used correctly).
Entering "eternal" loop is a bit unpleasant. Only Chuck Norris can exit one. Anyway, try to make a check before trimming and it will not enter:
Sub TestMe()
Dim p As Paragraph
For Each p In ThisDocument.Paragraphs
If p.Range <> Trim(p.Range) Then p.Range = Trim(p.Range)
Next p
End Sub
As has been said by #Cindy Meister, I need to prevent endless creation of another paragraphs by trimming them. I bear in mind that paragraph range contains at least 1 character, so processing range - 1 character would be safe. Following has worked for me
Sub ProcessParagraphs()
Set docContent = ActiveDocument.Content
' replace TAB symbols throughout the document to single space (trim does not remove TAB)
docContent.Find.Execute FindText:=vbTab, ReplaceWith:=" ", Replace:=wdReplaceAll
For Each p In ActiveDocument.Paragraphs
' delete empty paragraph (delete operation is safe, we cannot enter enternal loop here)
If Len(p.range.Text) = 1 Then
p.range.Delete
' remove whitespaces
Else
Set thisRg = p.range
' shrink range by 1 character
thisRg.MoveEnd wdCharacter, -1
thisRg.Text = Trim(thisRg.Text)
End If
p.LeftIndent = 0
p.FirstLineIndent = 0
p.Reset
p.range.Font.Reset
Next
With Selection
.ClearFormatting
End With
End Sub
I saw a number of solutions here are what worked for me. Note I turn off track changes and then revert back to original document tracking status.
I hope this helps some.
Option Explicit
Public Function TrimParagraphSpaces()
Dim TrackChangeStatus: TrackChangeStatus = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
Dim oPara As Paragraph
For Each oPara In ActiveDocument.StoryRanges(wdMainTextStory).Paragraphs
Dim oRange As Range: Set oRange = oPara.Range
Dim endRange, startRange As Range
Set startRange = oRange.Characters.First
Do While (startRange = Space(1))
startRange.Delete 'Remove last space in each paragraphs
Set startRange = oRange.Characters.First
Loop
Set endRange = oRange
' NOTE: for end range must select the before last characted. endRange.characters.Last returns the chr(13) return
endRange.SetRange Start:=oRange.End - 2, End:=oRange.End - 1
Do While (endRange = Space(1))
'endRange.Delete 'NOTE delete somehow does not work for the last paragraph
endRange.Text = "" 'Remove last space in each paragraphs
Set endRange = oPara.Range
endRange.SetRange Start:=oRange.End - 1, End:=oRange.End
Loop
Next
ActiveDocument.TrackRevisions = TrackChangeStatus
End Function
I'm building a Word document in VBA. I add a table row by row; once it's complete, I want to insert a blank line/paragraph and then start a new table. But when I add the paragraph after the table, the insertion point appears before the paragraph marker, so the next table is added there, and becomes part of the first table.
Set HeaderTableId = WordDoc.Tables.Add(Range:=wrdSel.Range, numcolumns:=3, numrows:=1, AutoFitBehavior:=wdWord9TableBehavior)
Set RowId = HeaderTableId.Rows(1)
RowId.Cells(1) = LeftHeader
RowId.Cells(2).Range.Font.Bold = True
RowId.Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
RowId.Cells(2) = CentreHeader
RowId.Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
RowId.Cells(3) = RightHeader
' (this table only has one row)
With HeaderTableId.Range
.Collapse (WdCollapseDirection.wdCollapseEnd)
.Move Unit:=wdCharacter, Count:=3
.Select
.InsertParagraph
End With
The final .InsertParagraph correctly inserts a blank paragraph after the table, but the insertion point is then before the paragraph marker.
I've also tried inserting a page break, but it has the same problem. I can't work out how to move the insertion point to the end.
I had to "flesh out" your code in order to test - I've pasted the entire test code below.
The key to inserting a second table following the first, separated by a paragraph mark to ensure the two tables are not merged:
It's necessary to collapse the table Range twice: once before and once after inserting the new paragraph.
The code in the question uses .Move, which is unclear as to how the Range is changed. If I were to use a "move" I'd go with .MoveStart which will keep a collapsed range collapsed, but for this problem I prefer Collapse. (There's also MoveEnd, which will extend a collapsed Range to include content.)
What's also different in my version:
it uses a "working Range" that's independent of any table range - this is personal preference
it uses InsertAfter vbCr for inserting the new paragraph - again, personal preference: I always know that what's inserted is part of the Range object. Sometimes, with Insert methods the new content may not be part of the Range, but I know it is with InsertAfter and InsertBefore
The code:
Sub InsertSuccessiveTables()
Dim HeaderTableId As word.Table, nextTable As word.Table
Dim RowId As word.Row
Dim workRange As word.Range
Dim WordDoc As word.Document
Set WordDoc = ActiveDocument
Set workRange = Selection.Range
Set HeaderTableId = WordDoc.Tables.Add(Range:=workRange, numcolumns:=3, numrows:=1, AutoFitBehavior:=wdWord9TableBehavior)
Set RowId = HeaderTableId.Rows(1)
RowId.Cells(1).Range.text = "Left"
RowId.Cells(2).Range.Font.Bold = True
RowId.Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
RowId.Cells(2).Range.text = "Center"
RowId.Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
RowId.Cells(3).Range.text = "Right"
' (this table only has one row)
Set workRange = HeaderTableId.Range
With workRange
.Collapse WdCollapseDirection.wdCollapseEnd
.InsertAfter vbCr 'ANSI 13
.Collapse WdCollapseDirection.wdCollapseEnd
End With
Set nextTable = workRange.Tables.Add(workRange, 1, 4, AutoFitBehavior:=wdWord9TableBehavior)
End Sub
In my code below, when the word isn't there, all the table contente is deleted. How to fix it? Text is in Cell(1,1) for multiple tables.
Sub DeleteText()
StartWord = "Orientation:"
For Each oTbl In ActiveDocument.Tables
Set oRng = oTbl.Range
With oRng
.Find.Execute Findtext:=StartWord & "*", MatchWildcards:=True
.MoveStart wdCharacter, 0
.MoveEndUntil vbCr
.Delete
End With
Next
End Sub
First of all you need to add if statement which will check if your text is found. You will find that in the code below. However, I also improved the way you delete the whole content of cell where your text is found. My solution is better in situation when you have more lines/paragraphs/sentences in the cell.
Sub DeleteText_Improved()
Dim StartWord As String
Dim oTbl As Table
Dim oRng As Range
StartWord = "Mauris"
For Each oTbl In ActiveDocument.Tables
Set oRng = oTbl.Range
With oRng
.Find.Execute Findtext:=StartWord & "*", MatchWildcards:=True
If .Find.Found Then
'how to select whole cell range
oTbl.Cell(.Information(wdEndOfRangeRowNumber), _
.Information(wdEndOfRangeColumnNumber)).Range.Delete
End If
End With
Next
End Sub
Final remark- your code is working only for the first occurrence of the word you search for. It will not remove other cells where the word appears.