Resize row widths in many tables based on text string

Question

I am a newbie to vba code but have had some marginal success with basic macros for changing the format of tables, text and photos within Word documents. I have a document containing several tables containing both text and photos. The tables all have two columns and several rows, but some have rows which are TEXT | TEXT whilst some are TEXT | PHOTO.

I'd like to create a macro that searches for a specific string within a sentence with a cell, and then change the cell width of both cells within the row. I'd like to repeat this for all rows and all tables. The idea is to have the TEXT | TEXT rows set up with a longer first column (15cm) and a shorter second column (2.78cm) whilst the TEXT | PHOTO rows stay as they are. An example of the text string would be the term "Is the". Hopefully the attached photos will explain better.

Before

After

Please can anyone help? I've searched high and low for a solution without success.

Here is the code I have tried so far but I am getting a break due to errors suggesting I have Next without For but I have two of each?

Sub ColumnWidthText1()

Dim oTbl As Table
Dim oRow As Row
Dim TargetText As String

If Selection.Information(wdWithInTable) = False Then Exit Sub

TargetText = InputBox$("Is the")

For Each oTbl In ActiveDocument.Tables

    For Each oRow In Selection.Tables(1).Rows
        If oRow.Cells(1).range.Text = TargetText & vbCr & Chr(7) Then
                oRow.Cells(1).Width = InchesToPoints(5.2)
                oRow.Cells(2).Width = InchesToPoints(1.8)
    Next oRow
    
Next oTbl

End Sub

Answer 1

What you want might be achieved with code like:

Sub Demo()
Application.ScreenUpdating = False
Dim Tbl As Table, r As Long
For Each Tbl In ActiveDocument.Tables
  With Tbl
    If .Range.InlineShapes.Count > 0 Then
      For r = 1 To .Rows.Count
        If .Cell(r, 2).Range.InlineShapes.Count = 0 Then
          .Rows(c).Cells.DistributeWidth
        End If
      Next
    End If
  End With
Next
Application.ScreenUpdating = True
End Sub

Alternatively:

Sub Demo()
Application.ScreenUpdating = False
Dim Tbl As Table, r As Long
For Each Tbl In ActiveDocument.Tables
  With Tbl
    If .Range.InlineShapes.Count > 0 Then
      For r = 1 To .Rows.Count
        If .Cell(r, 2).Range.InlineShapes.Count = 0 Then
          .Cell(r, 1).Width = InchesToPoints(5.2)
          .Cell(r, 2).Width = InchesToPoints(1.8)
        End If
      Next
    End If
  End With
Next
Application.ScreenUpdating = True
End Sub