asked on

I need a macro to search text, in table cells only, of a particular style!

Greetings experts!
I'm reaching out to you for help with another bit of code that I just can't figure out.

I have a Chinese document in Word where the last line of EVERY paragraph must have more than one character besides punctuation. I have written a macro to search for all paragraph marks of a number of styles, move left three characters, and insert a zero-width, non-breaking character. This works great on all content except for paragraphs inside tables since there aren't paragraph marks (unless there are more than one paragraph) and you can't search for the "end of table cell" mark.

We use tables (typically 2-column) in our documents to help format text & associated graphics (instead of using inline graphics). We have a graphic in the left column and text in the right column, or the other way around. We use one of 7 different styles for the text in the table cells (i.e., Body Text, Table Text, etc.).

I need to search just tables for certain styles and do the same thing I've done with the aforementioned macro.

Here's the macro solution that works for all the content not in tables. If this can be modified to include the table content, I'd love the help. If not, how do I search just tables to do this?

Option Explicit

Sub InsertZeroWidthSpace()

Dim rng As Range
Dim i As Long

    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:="5"
    
    For i = 1 To 19
        Set rng = ActiveDocument.Range
        With rng.Find
            .ClearFormatting
            .Text = "^p"
            .Style = Choose(i, "Body Text", "Body Text - After Table", "List Bullet Checkmark", "Body Text 2 - PreNumbered", _
                "Body Text Indent", "List Bullet Box", "Table Text L - Parts", "Step", "Step Text", "Table Text L - 9 pt", _
                "Legend List", "List", "List Continue", "Legend List Bullet Indent", "List Bullet Box Indent", _
                "Step Result", "Caution Bullet", "Body Text - PreNumbered", "Legend List Continue")
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
 
        While rng.Find.Execute
            rng.Select
            Selection.MoveLeft Unit:=wdCharacter, Count:=3
            Selection.InsertSymbol CharacterNumber:=8205, Unicode:=True, Bias:=0
        Wend
        
        End With
    Next i
    
End Sub

Open in new window

If anyone out there has a solution or suggestions, I'll give you the max points possible!! HELP!

Thanks so much in advance.
Jan

Rgonzo1971

Hi,

pls try

Option Explicit

Sub InsertZeroWidthSpace()

Dim rng As Range
Dim i As Long

    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:="5"
    
    For i = 1 To 19
        Set rng = ActiveDocument.Range
        Call SearchAndInsert(rng, i)
        For Each tbl In ActiveDocument.Tables
            For Each rw In tbl.Rows
                For Each c In rw.Cells
                    Set rng = c.Range
                    Call SearchAndInsert(rng, i)
                Next
            Next
        Next
    Next i
    
End Sub

Sub SearchAndInsert(ByVal rng As Range, ByVal i As Integer)
        With rng.Find
            .ClearFormatting
            .Text = "^p"
            .Style = Choose(i, "Body Text - After Table", "List Bullet Checkmark", "Body Text 2 - PreNumbered", _
                "Body Text Indent", "List Bullet Box", "Table Text L - Parts", "Step", "Step Text", "Table Text L - 9 pt", _
                "Legend List", "List", "List Continue", "Legend List Bullet Indent", "List Bullet Box Indent", _
                "Step Result", "Caution Bullet", "Body Text - PreNumbered", "Legend List Continue")
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
 
        While rng.Find.Execute
            rng.Select
            Selection.MoveLeft Unit:=wdCharacter, Count:=3
            Selection.InsertSymbol CharacterNumber:=8205, Unicode:=True, Bias:=0
        Wend
        End With
End Sub

Open in new window

Regards

jbarcher13

ASKER

Hi! Thanks for getting back to me so quickly. I've tried the code and I'm getting this error message:

Error 5991:
Cannot access individual rows in this collection because the table has vertically merged cells.

I also noticed that "rw" "c" and "tbl" were not declared. Here's the code now:

Option Explicit

Sub InsertZeroWidthSpace()

Dim rng As Range
Dim i As Long
Dim tbl As Table
Dim rw As Row
Dim c As Cell

    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:="5"
    
    For i = 1 To 19
        Set rng = ActiveDocument.Range
        Call SearchAndInsert(rng, i)
        For Each tbl In ActiveDocument.Tables
            For Each rw In tbl.Rows
                For Each c In rw.Cells
                    Set rng = c.Range
                    Call SearchAndInsert(rng, i)
                Next
            Next
        Next
    Next i
    
End Sub

Sub SearchAndInsert(ByVal rng As Range, ByVal i As Integer)
        With rng.Find
            .ClearFormatting
            .Text = "^p"
            .Style = Choose(i, "Body Text - After Table", "List Bullet Checkmark", "Body Text 2 - PreNumbered", _
                "Body Text Indent", "List Bullet Box", "Table Text L - Parts", "Step", "Step Text", "Table Text L - 9 pt", _
                "Legend List", "List", "List Continue", "Legend List Bullet Indent", "List Bullet Box Indent", _
                "Step Result", "Caution Bullet", "Body Text - PreNumbered", "Legend List Continue")
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
 
        While rng.Find.Execute
            rng.Select
            Selection.MoveLeft Unit:=wdCharacter, Count:=3
            Selection.InsertSymbol CharacterNumber:=8205, Unicode:=True, Bias:=0
        Wend
        End With
End Sub

Open in new window

Is there a way to skip those kind of tables without causing any problems?

Thanks, Jan

Rgonzo1971

Hi,

pls try

Sub InsertZeroWidthSpace()

Dim rng As Range
Dim i As Long

    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:="5"
    
    For i = 1 To 19
        Set rng = ActiveDocument.Range
        Call SearchAndInsert(rng, i)
        For Each tbl In ActiveDocument.Tables
            For r = 1 To tbl.Rows.Count
                For c = 1 To tbl.Columns.Count
                    On Error Resume Next
                    Set cl = tbl.Cell(r, c)
                    On Error GoTo 0
                    Set rng = cl.Range
                    If Not (IsEmpty(cl)) Then
                        Call SearchAndInsert(rng, i)
                    End If
                Next
            Next
        Next
    Next i
    
End Sub

Open in new window

Regards

jbarcher13

ASKER

Hi!

Well, I must be doing something wrong. I might be using the incorrect variable declarations for "cl", "c", "tbl", and "r" because I'm getting a Type Mismatch error message when I try to run this. Can you point out the error of my ways, please?

Also, I just noticed in the SearchAndInsert(ByVal rng As Range, ByVal i As Integer) sub, you're still searching for "^p" and there are no paragragph marks in table cells if there is only one paragraph (which happens 98% of the time with my case). Do I need to have this?

Here's what I have:

Option Explicit

Sub InsertZeroWidthSpace()

Dim rng As Range
Dim i As Long
Dim tbl As Table
Dim rw As Row
Dim cl As Cell
Dim r As Row
Dim c As Column
    
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:="5"
    
    For i = 1 To 8
        Set rng = ActiveDocument.Range
        Call SearchAndInsert(rng, i)
        For Each tbl In ActiveDocument.Tables
            For r = 1 To tbl.Rows.Count
                For c = 1 To tbl.Columns.Count
                    On Error Resume Next
                    Set cl = tbl.Cell(r, c)
                    On Error GoTo 0
                    Set rng = cl.Range
                    If Not (IsEmpty(cl)) Then
                        Call SearchAndInsert(rng, i)
                    End If
                Next
            Next
        Next
    Next i
    
End Sub
   
Sub SearchAndInsert(ByVal rng As Range, ByVal i As Integer)
        With rng.Find
            .ClearFormatting
            .Text = "^p"
            .Style = Choose(i, "Body Text", "Table Text L - Parts", "Step", "Table Text L - 9 pt", _
                "List", "List Continue", "Table Text Centered - 8 pt", "Step Result")
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
 
        While rng.Find.Execute
            rng.Select
            Selection.MoveLeft Unit:=wdCharacter, Count:=3
            Selection.InsertSymbol CharacterNumber:=8205, Unicode:=True, Bias:=0
        Wend
        End With
End Sub

Open in new window

Thanks for your help! Jan

Saqib Husain

Can you upload a sample file for testing?

Faustulus

Hi,
I think your code is something of an overkill. Yousee, the paragraph mark is the same for all styles. Therefore you don't need to specify any. Also, ActiveDocument.Range includes all sections. Therefore your code would run 16 times, adding 16 characters(8205) in the specified locations.
Because of these observations I have taken a rather different approach. The code appended below isolates the last 3 characters in each paragraph or - in a separate operation - each cell of each table. The last two are one Chinese character, and the first might be the replacement character. If it is, no action will be taken. If not, it is inserted before the last 2 characters.

Sub OrphanControl()

    Dim Fnd As Range
    Dim Tbl As Table
    Dim Cll As Cell
    Dim Rng As Range
    
    Set Fnd = ActiveDocument.Content
    With Fnd.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = Chr(13)
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .Execute
    End With

    While Fnd.Find.Found
        With Fnd
            If .Paragraphs(1).Range.Characters.Count > 3 Then
                Set Rng = ActiveDocument.Range(Start:=.Start - 3, End:=.Start)
                InsertCharacter Rng
            End If
            .Find.Execute
        End With
    Wend
    
    If ActiveDocument.Tables.Count Then
        For Each Tbl In ActiveDocument.Tables
            For Each Cll In Tbl.Range.Cells
                With Cll.Range
                    If .Characters.Count > 3 Then
                        Set Rng = ActiveDocument.Range(Start:=.End - 4, End:=.End - 1)
                        InsertCharacter Rng
                   End If
                End With
            Next Cll
        Next Tbl
    End If
End Sub

Private Sub InsertCharacter(Rng As Range)
    
    Const NewChar As Long = 8205
    Dim Txt As String
    
    Txt = Rng.Text
    If AscW(Txt) <> NewChar Then
        Txt = Left(Txt, 1) & ChrW(NewChar) & Mid(Txt, 2)
        Rng.Text = Txt
    End If
End Sub

Open in new window

I didn't test the code with Chinese characters and, actually, don't know what might happen if the 4th character from the end is half a character which is being tested. I expect it to be OK, but if this throws an error please do let me know.

I haven't taken final interpunctuation into consideration. If you need to allow, say a full stop, at the end in addition to a single text character please advise the Unicode numbers of the characters you wish to allow and I will adjust my code.

ASKER CERTIFIED SOLUTION

jbarcher13

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Faustulus

It just occurs to me that there might be a problem with cells containing drawings. Characters 8205 might be inserted into them. I would need one sample row of your table, with content, to amend my program not to do its magic on cells that don't contain text.

jbarcher13

ASKER

Very thorough.