Copying text font color from first cell to all cells in a table row

[frtadros]

Hi, I have a powerpoint presentation and each slide has a table

for each row in the table, I want to copy the color of the text in the first cell to all cells in the same row
this is the code but it just does not do anything

thank you


Sub ChangeColor(sStart As Integer, sEnd As Integer)
Dim sColor As Long
Dim oSld As Slide
Dim oShp As Shape
Dim oRow As Row
Dim oCell As Cell
Dim x As Long
Dim oColor As Long

With ActivePresentation
For I = sStart To sEnd + 1
Set oSld = ActivePresentation.Slides(I)
For Each oShp In oSld.Shapes
If oShp.HasTable Then
For Each oRow In oShp.Table.Rows
For Each oCell In oRow.Cells
If oCell.Shape.TextFrame.HasText Then
With oCell.Shape.TextFrame.TextRange
For x = 1 To .Runs.Count
If x = 1 Then
oColor = .Runs(x).Font.Color.RGB
Else
.Runs(x).Font.Color.RGB = oColor
End If
Next x
End With
End If 'has text
Next oCell
Next oRow
End If
Next oShp
Next I
End With
End Sub

[frtadros]

I apologize for not being able to show the code in indent format. in edit mode, it shows correctly but after posting all lines are left justified
I would like to know how to sow it properly
thanks

[SamT]

Leading spaces are trimmed in View Mode.

You can use the # icon to insert Code Formatting Tags around the selected Text.
you can also Insert the Code Formatting Tags, then Paste the code between them.

I don't do PowerPoint, but place "Option Explicit" at the very top of the code module, then Compile the code.

[frtadros]

Thank you SamT for your prompt reply and assistance

[Paul_Hossler]

Try this




Option Explicit

Sub drv()
Call ChangeColor(1, 3)
End Sub

Sub ChangeColor(sStart As Integer, sEnd As Integer)
Dim sColor As Long
Dim oSld As Slide
Dim oShp As Shape
Dim oRow As Row
Dim oCell As Cell
Dim x As Long, i As Long
Dim oColor As Long

With ActivePresentation
For i = sStart To sEnd ' why the +1 ?
Set oSld = ActivePresentation.Slides(i)
For Each oShp In oSld.Shapes
If oShp.HasTable Then
For Each oRow In oShp.Table.Rows
For Each oCell In oRow.Cells
If oCell.Shape.TextFrame.HasText Then
oCell.Shape.TextFrame.TextRange.Font.Color.RGB = oRow.Cells(1).Shape.TextFrame.TextRange.Font.Color.RGB
End If 'has text
Next oCell
Next oRow
End If
Next oShp
Next i
End With
End Sub