Word VBA to format table

[FredrikNilsen]

Hello,

I have a document with several tables. Some of the tables have rows with specific words ("Program", "Time"). I would like to search through the document, find each row with those words, and apply a specific style ("P1", "P2") to the whole row with the words. I have started with a code to clean up the tables first, but I don't know how to search for the rows and apply the styles.

Dim Tbl As Table
    For Each Tbl In ActiveDocument.Tables
        Tbl.Range.Font.Name = "Arial Nova"
        Tbl.Range.Rows.HeightRule = wdRowHeightAuto
        Tbl.Range.Font.Size = 10
                
    Next Tbl

 

[NdNoviceHlp]

Hi Fredrik. This seems to work. I don't have anymore time right now to further expand the code. You will need to adjust the file path and ensure that your style exists in the document. HTH. Dave

Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)

SearchArr = Array("Program", "Time")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
If InStr(LCase(TblCell.Range), LCase(SearchArr(Arrcnt))) Then
WrdApp.ActiveDocument.Tables(Cnt).Rows(TblCell.RowIndex).Range.Style = "P1" '"Heading 1"
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub

 

[NdNoviceHlp]

Hi again Fredrik. This makes more sense to me and should be quicker. Dave

Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object
Dim Cnter As Integer
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)

SearchArr = Array("Program", "Time")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table rows
For Cnter = 1 To WrdApp.ActiveDocument.Tables(Cnt).Rows.Count
If InStr(LCase(WrdApp.ActiveDocument.Tables(Cnt).Rows(Cnter)), LCase(SearchArr(Arrcnt))) Then
WrdApp.ActiveDocument.Tables(Cnt).Rows(Cnter).Range.Style = "Heading 1" '"P1"
End If
Next Cnter
Next Arrcnt
Next Cnt
End Sub

 

[FredrikNilsen]

Hi again Fredrik. This makes more sense to me and should be quicker. Dave

Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object
Dim Cnter As Integer
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True

'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)

SearchArr = Array("Program", "Time")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table rows
For Cnter = 1 To WrdApp.ActiveDocument.Tables(Cnt).Rows.Count
If InStr(LCase(WrdApp.ActiveDocument.Tables(Cnt).Rows(Cnter)), LCase(SearchArr(Arrcnt))) Then
WrdApp.ActiveDocument.Tables(Cnt).Rows(Cnter).Range.Style = "Heading 1" '"P1"
End If
Next Cnter
Next Arrcnt
Next Cnt
End Sub

Thank you, I really appreciate it. I will note it. I forgot to mention: I'm doing this inside Word, in an already open document. I made it work with this added to the code above:

Dim myRow As Row
    For Each Tbl In ActiveDocument.Tables
    For Each myRow In Tbl.Rows
        If myRow.Cells(1).Range.Characters(1).Text = "P" Then
        myRow.Range.Style = ActiveDocument.Styles("P1")
        End If
    
        If myRow.Cells(1).Range.Characters(1).Text = "T" Then
        myRow.Range.Style = ActiveDocument.Styles("P2")
        
        End If
    Next
    Next

This just searches for the first letter (Characters(1)) in the first cell (Cells(1)) in any row. I just don't understand how to make it search for the whole word, though it's working just for now.

 

[NdNoviceHlp]

This seems like it should work in Word. Dave

Dim myRow As Row, Cnt As Integer, Cnter As Integer
For Cnt = 1 To ActiveDocument.Tables.Count
For Cnter = 1 To ActiveDocument.Tables(Cnt).Rows.Count
If InStr(ActiveDocument.Tables(Cnt).Rows(Cnter), "Program") Then
ActiveDocument.Tables(Cnt).Rows(Cnter).Range.Style = "P1"
End If
If InStr(ActiveDocument.Tables(Cnt).Rows(Cnter), "Time") Then
ActiveDocument.Tables(Cnt).Rows(Cnter).Range.Style = "P2"
End If
Next Cnter
Next Cnt