macro VBA PowerPoint calculating the MIN and MAX in a table

[romelsms1]

please tell me how to create a macro in power point for a table.
I try to change the font cell color for the highest and lowest no for each line
I use powerpoint 2003

for n lines end m columns

[John Wilson]

Maybe something based on:
Sub chex_table()
Dim ir As Integer
Dim ic As Integer
Dim imax As Integer
Dim imin As Integer
Dim cmax As Integer
Dim cmin As Integer
On Error Resume Next
With ActiveWindow.Selection.ShapeRange(1).Table
For ir = 1 To .Rows.Count
For ic = 1 To .Columns.Count
If IsNumeric(.Cell(ir, ic).Shape.TextFrame.TextRange) Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
Exit For
End If
Next
imax = imin
For ic = 1 To .Columns.Count
If IsNumeric(.Cell(ir, ic).Shape.TextFrame.TextRange) Then
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) >= imax Then
imax = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
cmax = ic
End If
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) <= imin Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
cmin = ic
End If
End If
Next
.Cell(ir, cmax).Shape.TextFrame.TextRange.Font.Color = vbRed
.Cell(ir, cmin).Shape.TextFrame.TextRange.Font.Color = vbGreen
Next
End With
End Sub

[romelsms1]

Maybe something based on:
Sub chex_table()
Dim ir As Integer
Dim ic As Integer
Dim imax As Integer
Dim imin As Integer
Dim cmax As Integer
Dim cmin As Integer
On Error Resume Next
With ActiveWindow.Selection.ShapeRange(1).Table
For ir = 1 To .Rows.Count
For ic = 1 To .Columns.Count
If IsNumeric(.Cell(ir, ic).Shape.TextFrame.TextRange) Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
Exit For
End If
Next
imax = imin
For ic = 1 To .Columns.Count
If IsNumeric(.Cell(ir, ic).Shape.TextFrame.TextRange) Then
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) >= imax Then
imax = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
cmax = ic
End If
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) <= imin Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
cmin = ic
End If
End If
Next
.Cell(ir, cmax).Shape.TextFrame.TextRange.Font.Color = vbRed
.Cell(ir, cmin).Shape.TextFrame.TextRange.Font.Color = vbGreen
Next
End With
End Sub
Thanks John Wilson
Starting from your code (now i have an idea) i can update it exactly for my needs: if i have 2 or more nim or max nombers i want to mark them all and to change the fill cell color not font color for min/max

[romelsms1]

question:

Is there any chance to compare only the numbers not characters after numbers ( * in my case) ?

[John Wilson]

Do you mean EXCLUDE values with a start?

Sub chex_table()
Dim ir As Integer
Dim ic As Integer
Dim imax As Integer
Dim imin As Integer
Dim cmax As Integer
Dim cmin As Integer
Dim txtR As TextRange
On Error Resume Next
With ActiveWindow.Selection.ShapeRange(1).Table
For ir = 1 To .Rows.Count
For ic = 1 To .Columns.Count
Set txtR = .Cell(ir, ic).Shape.TextFrame.TextRange
If IsNumeric(txtR.Characters(txtR.Length)) Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
Exit For
End If
Next
imax = imin
For ic = 1 To .Columns.Count
Set txtR = .Cell(ir, ic).Shape.TextFrame.TextRange
If IsNumeric(txtR) Then
If Val(txtR) >= imax Then
imax = Val(txtR)
cmax = ic
End If
If Val(txtR) <= imin Then
imin = Val(txtR)
cmin = ic
End If
End If
Next
.Cell(ir, cmax).Shape.TextFrame.TextRange.Font.Color = vbRed
.Cell(ir, cmin).Shape.TextFrame.TextRange.Font.Color = vbGreen
Next
End With
End Sub

Should give you a start.

[John Wilson]

That was "With a STAR"

Just checking and I guess I have it wrong because the original code should have already excluded the starred numbers.
maybe you mean INCLUDE the starred numbers?

Change the line which tests for Numeric ie
If IsNumeric ......Then

To:

If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) > 0 Then

[romelsms1]

yes I mean INCLUDE the starred numbers, but its not working :(

[John Wilson]

Strange this seems to work here:
Sub chex_table()
Dim ir As Integer
Dim ic As Integer
Dim i As Integer
Dim imax As Integer
Dim imin As Integer

On Error Resume Next
With ActiveWindow.Selection.ShapeRange(1).Table
For ir = 1 To .Rows.Count
For ic = 1 To .Columns.Count
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) > 0 Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
Exit For
End If
Next
imax = imin
For ic = 1 To .Columns.Count
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) > 0 Then
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) >= imax Then
imax = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
End If
If Val(.Cell(ir, ic).Shape.TextFrame.TextRange) <= imin Then
imin = Val(.Cell(ir, ic).Shape.TextFrame.TextRange)
End If
End If
Next
For i = 1 To .Columns.Count
If Val(.Cell(ir, i).Shape.TextFrame.TextRange) = imin and imin > 0 Then _
.Cell(ir, i).Shape.Fill.ForeColor.RGB = vbRed
If Val(.Cell(ir, i).Shape.TextFrame.TextRange) = imax and imax > 0 Then _
.Cell(ir, i).Shape.Fill.ForeColor.RGB = vbGreen
Next i
Next
End With
End Sub

[romelsms1]

I try to add properties to cells...and i have a problem: I do not know how to position the text in middle centered. I did only for the vertical...

.Cell(ir, ic).Shape.TextFrame.TextRange.Font.Name = "Arial"
.Cell(ir, ic).Shape.TextFrame.TextRange.Font.Size = 10
.Cell(ir, ic).Shape.TextFrame.TextRange.Font.Bold = msoTrue
.Cell(ir, ic).Shape.TextFrame.TextRange.Lines.ParagraphFormat.Alignment = ppAlignCenter

[John Wilson]

With .Cell(ir, ic).Shape.TextFrame
.VerticalAnchor=msoAnchorMiddle
.TextRange.Font.Name = "Arial"
.TextRange.Font.Size = 10
.TextRange.Font.Bold = msoTrue
.TextRange.Lines.ParagraphFormat.Alignment = ppAlignCenter
End With