Find tables by using Word macro

[Sam1085]

Hi,

I've a document that contains too many tables (50-100). Some table rows have cell shading. But few tables haven't any shading color. Entire document have only one shading RGB color.

I need to find only shading applied tables (Ignore other tables) and run a macro for each tables. Any easy way to do that?

Thanks!

[HansV]

You could use a macro like this:

Code: Select all

Sub ShadedTables()
    Dim tbl As Table
    For Each tbl In ActiveDocument.Tables
        If tbl.Shading.BackgroundPatternColor <> wdColorAutomatic Then
            tbl.Select
            ' Run your macro here. It can act on the selected table.
            Call MyMacro
        End If
    Next tbl
End Sub

[Sam1085]

Hi Hans,

Wow It's amazing. I'll customize this per my requirements.

[Sam1085]

Another scenario is some tables split into multiple pages (No repeat header rows enabled any table). Any option to find those tables?

Thanks!

[HansV]

Like this:

Code: Select all

Sub DetectSplitTables()
    Dim tbl As Table
    Dim lngStart As Long
    Dim lngEnd As Long
    For Each tbl In ActiveDocument.Tables
        lngStart = tbl.Range.Start
        lngEnd = tbl.Range.End - 1 ' Subtract 1 because .Range.End is below the table.
        If ActiveDocument.Range(lngStart, lngStart).Information(wdActiveEndPageNumber) < _
                ActiveDocument.Range(lngEnd, lngEnd).Information(wdActiveEndPageNumber) Then
            tbl.Select
            Call MyMacro
        End If
    Next tbl
End Sub

[Sam1085]

Thanks,

This is exactly what I needed.

[Sam1085]

You could use a macro like this:

Code: Select all

Sub ShadedTables()
    Dim tbl As Table
    For Each tbl In ActiveDocument.Tables
        If tbl.Shading.BackgroundPatternColor <> wdColorAutomatic Then
            tbl.Select
            ' Run your macro here. It can act on the selected table.
            Call MyMacro
        End If
    Next tbl
End Sub

I just trying to select shading included first cell to bottom cell. (See below attached image.)

01.png

But something went wrong. And I've no Idea about how to select those cells except entire column.

Code: Select all

Private Sub SelectTable()
    Dim c As Cell
    For Each c In ActiveDocument.Range.Cells
         If c.Shading.BackgroundPatternColor <> wdColorAutomatic Then
            c.Select
         End If
    Next c
End Sub

[HansV]

Did you get an error message? If so, what did it say?

(I'll be away for some hours with limited access to a computer, so I won't be able to reply immediately).

[Sam1085]

Hi Hans,

I didn't get any error massages. But above mentioned code will select the first cell of the table. My target is select cells as above screen-shot.

Thanks for the quick responses. take your time and response back... Thanks!

[HansV]

You can check whether the cell is in the first column by checking

Code: Select all

        If cel.ColumnIndex = 1 Then
            ...
        End If

You can perform an action on each cell as it is selected, for example run a macro, or change the font color of the cell, or make the text bold, or whatever. If you merely loop through the cells and only select each cell in turn, nothing useful will happen.

[Rudi]

How about:

Code: Select all

Sub SelectFirstColumn()
  Dim rng As Range
  If Selection.Information(wdWithInTable) Then
    Set rng = Selection.Tables(1).Cell(2, 1).Range
    rng.Collapse Direction:=wdCollapseStart
    rng.Select
    Selection.EndKey Unit:=wdColumn, Extend:=True
  End If
End Sub

[Sam1085]

Hi Hans,

Thanks now 80% done in my expectation

But I've no idea about how to select first cell of the table. First cell means shading included first cell of the table. See below image for more clarity.

img2.png

Final goal is add leader dots into the selected cells (Except table captions).

img3.png

Earlier my request is select shading included table and then select first column of the table. But I've no option to ignore table captions. That's why I'm again change my concept. Thanks for helping!

[HansV]

Does this do what you want? Please test it thoroughly!

Code: Select all

Sub Testing()
    Dim tbl As Table
    Dim r As Long
    Dim w As Single
    Application.ScreenUpdating = False
    For Each tbl In ActiveDocument.Tables
        If tbl.Cell(2, 1).Shading.BackgroundPatternColor <> wdColorAutomatic Then
            For r = 2 To tbl.Rows.Count
                With tbl.Cell(r, 1)
                    w = .Width - .LeftPadding - .RightPadding
                    With .Range
                        With .ParagraphFormat.TabStops
                            .ClearAll
                            .Add Position:=w, Leader:=wdTabLeaderDots
                        End With
                        .InsertAfter Text:=vbTab
                    End With
                End With
            Next r
        End If
    Next tbl
    Application.ScreenUpdating = True
End Sub

[Sam1085]

Yes it's works for some tables. But in my some table captions goes to more than 1 row. That's why I've to find shading included first cell of the table. Any way to do that?

Thanks!

[HansV]

The requirements keep changing all the time!

Code: Select all

Sub Testing()
    Dim tbl As Table
    Dim f As Boolean
    Dim r1 As Long
    Dim r As Long
    Dim w As Single
    Application.ScreenUpdating = False
    For Each tbl In ActiveDocument.Tables
        f = False
        For r1 = 1 To tbl.Rows.Count
            If tbl.Cell(r1, 1).Shading.BackgroundPatternColor <> wdColorAutomatic Then
                f = True
                Exit For
            End If
        Next r1
        If f Then
            For r = r1 To tbl.Rows.Count
                With tbl.Cell(r, 1)
                    w = .Width - .LeftPadding - .RightPadding
                    With .Range
                        With .ParagraphFormat.TabStops
                            .ClearAll
                            .Add Position:=w, Leader:=wdTabLeaderDots
                        End With
                        .InsertAfter Text:=vbTab
                    End With
                End With
            Next r
        End If
    Next tbl
    Application.ScreenUpdating = True
End Sub

[Sam1085]

Hi Hans,

Thanks, That code works for some documents. But in my document types not works properly. I've no idea about what's the reason for that.. Here with I've attached a sample document for your reference.

Sample Document.docx

And also my dot leaders adding macro is complex. It'll ignore (:) colon characters and blank cells while adding the dot leaders.

Code: Select all

Private Sub Add_DotLeaders()
    Const aCOLON = 58
    Const aRETURN = 13
    Const aTAB = 9
    Const aCELLFORMAT = 7

    Dim Tabvalue As Integer
    Dim x As Integer
    Dim CompChar As String
    Dim tstring As String
    Dim c As Cell

    For Each c In Selection.Cells
        Tabvalue = c.Width - c.RightPadding
        With c.Range.ParagraphFormat.TabStops
            .ClearAll
            .Add Position:=Tabvalue, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
        End With
        With c.Range
            tstring = .Text
            If Len(Trim(tstring)) > 2 Then
                For x = Len(.Text) - 1 To 1 Step -1
                    CompChar = Mid(tstring, x, 1)
                    Select Case (CompChar)
                        Case Chr(aCOLON)
                            Exit For
                        Case Chr(aRETURN)
                            If Len(tstring) > 1 Then
                                tstring = Left(tstring, Len(tstring) - 1)
                            End If
                        Case Chr(aCELLFORMAT)
                            If Len(tstring) > 1 Then
                                tstring = Left(tstring, Len(tstring) - 1)
                            End If
                        Case Else 'Stop loop when found char other then 7, 13, 58 is found
                            .InsertAfter (Chr(9))
                            Exit For
                    End Select
                Next
            End If
        End With
    Next c
End Sub

[HansV]

In your sample document, the shading of the cells in row 1 is not automatic, but white. Do you want to exclude white as well as automatic?

[Sam1085]

Ah.. That's the case. Yes please can you ignore both white and automatic?

And I've to link my dot leader adding macro to that code. I know it's crazy
Thanks for helping!

[HansV]

Here you go:

Code: Select all

Sub Testing()
    Dim tbl As Table
    Dim f As Boolean
    Dim r1 As Long
    Dim r As Long
    Dim w As Single
    Application.ScreenUpdating = False
    For Each tbl In ActiveDocument.Tables
        f = False
        For r1 = 1 To tbl.Rows.Count
            Select Case tbl.Cell(r1, 1).Shading.BackgroundPatternColor
                Case wdColorAutomatic, wdColorWhite
                    ' Skip these
                Case Else
                    f = True
                    Exit For
            End Select
        Next r1
        If f Then
            For r = r1 To tbl.Rows.Count
                tbl.Cell(r, 1).Select
                Call Add_DotLeaders
            Next r
        End If
    Next tbl
    Application.ScreenUpdating = True
End Sub

[Sam1085]

Thank you Hans,

Now It's works well. That's the ultimate goal.

Additionally I think this macro can speed-up by using this code to select all cells. I think currently it's run cell by cell. So, may I know which parts of code should I edit to do that?

Code: Select all

Selection.EndKey Unit:=wdColumn, Extend:=True