PowerPoint VBA Cell Shading

[macreator]

Hi,

I have attached a BMP screenshot of the table I would like to manipulate via a VBA macro in PowerPoint.

In the second column I have a list of attributes and in the third column (total) I have a list of the percentage of customers who value this attribute. In columns four, five, six and seven I have a list of the percentage of customers within groups 1, 2, 3, and 4 that value this attribute.

Is it possible to create a VBA script for PowerPoint that would shade the background of cells in columns 4, 5, 6 and 7 depending upon whether the number in the cell is at least 4 points higher than or 4 points lower than the number in column 3?

Essentially to take row two for example: Has Extra Long Battery Life is the attribute in column 2, 74 is the total in column 3, 73 is the number in column 4, 82 is the number in column 5, 71 is the number is column 6 and 70 is the number in column 7.

I want to shade blue cells in that row that have values at least 4 points greater than the value in column 3 of that row and shade red cells in that row that have values at least 4 points lower than the value in column 3 of that row.

So, for the Has Extra Long Battery Life row, column 5 (customer group 2) would be shaded blue since it is at least 4 points higher than the total column value (74) and column 7 (customer group 4) would be shaded red since it is at least 4 points lower than the total column value.

[John Wilson]

Here's a quick demo of how you might approach it.

DEMO (http://www.pptalchemy.co.uk/Downloads/table.pptm)

[macreator]

Hi John,

Thanks so much for the help! This is indeed a great start.

How would I go about having the macro repeat the process for each row of the table? Right now it can only do one row since it defines the control value for which it is shading off of as a fixed cell in the table. Can I have it use the column 2 value as the control value in each row as it goes through the table? Essentially have the macro loop until it runs out of rows.

Thanks so much for your help!

Nick

[John Wilson]

Just loop through the rows.

See This (http://www.pptalchemy.co.uk/Downloads/table2.pptm)

[macreator]

Perfect -- that's a huge help! Thanks!

I have two related questions -- I've added in InputBoxes so that the user running the macro can independently define the point difference they would like to use as well as which column they would like to use as the control value and which row the data starts on (typically two but you never know) without having to go into the code.

Is it possible to somehow use the user's mouse selection to define these values instead of through InputBoxes? For instance could the user simply highlight/select the relevant columns and rows they would like the macro to roll through?

And finally in that same vein, right now the macro needs to be manually tweaked if used on another slide since the number of shapes on the slide are different. Is there any way to avoid that issue?

Thanks so much once again! Wish I could buy you a beer!

[John Wilson]

Well my wife is landing at JFK as we speak!

Are you working in edit view or slide show view. If the latter then you cannot select cells to change if edit view you can check whether a cell is selected

If otbl.cell(n,i).Selected Then ... else ... end if

If all your tables are called Table x you can loop through the shapes and find it

If Name Like "Table*" then this is it

If there's only one table you could check the shape type

If oshp.Type=msoTable Then ....

Hope that helps

Now I have to pick up the phone as the plane lands!!

[macreator]

Haha, small world! Not a bad weekend to be in New York -- pretty quiet due to our Labor Day holiday. Hopefully she had a good time!

I'm working in edit view. I'm still a macro novice so I'm a little confused about the implementation for having the macro select the table.

There will always be just one table on each slide that I want to manipulate. Would I then want to replace the Set otbl = ActivePresentation.Slides(1).Shapes(1).Table with If oshp.Type=msoTable Then?

Maybe I should get this working before attempting having the macro select the rows/cols based on user mouse selection.

Thanks so much!

[John Wilson]

You can't jUST say if oshp.type=msoTable you need to loop through all the slides shapes and check this:

For Each osld in ActivePresentation.Slides
For each oshp in osld .Shapes
If oshp.Type=mspTable then
'do whatever to oshp.Table
'if there is only ONE table leave the loop (Exit For)
End If
Next oshp
next osld

[macreator]

Hi,

Is there a way to instead simply have the macro recognize which table in the slide the user has selected and run based on that active table?

While I initially thought there would be just one table per slide it turns out that my assumption was faulty. Right now then the macro works but it requires me to copy the table I want to shade into its own empty slide.

If I could get this working I think I would be set with this macro. Even in its current state it has already saved me countless hours! Thanks so much for your help, John!

For reference, here is my code thus far:

Option Explicit
Sub tableshader()
Dim otbl As Table
Dim i As Integer
Dim n As Integer
Dim sngComp As Single
Dim ptinput As Integer
Dim colstart As Integer
Dim rowstart As Integer
ptinput = InputBox("Enter the desired significant point difference")
colstart = InputBox("Enter the column number for Total")
rowstart = InputBox("Enter the row number that the data begins on")
On Error Resume Next
Set otbl = ActivePresentation.Slides(1).Shapes(1).Table
If Not otbl Is Nothing Then
With otbl
For n = rowstart To .Rows.Count
sngComp = Val(.Cell(n, colstart).Shape.TextFrame.TextRange)
For i = colstart + 1 To .Rows(n).Cells.Count
Select Case Val(.Cell(n, i).Shape.TextFrame.TextRange)
Case Is >= sngComp + ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(35, 80, 98)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
End If
Case Is <= sngComp - ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(127, 0, 15)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
End If
End Select
Next i
Next n
End With
MsgBox ("Success")
Else
MsgBox ("Failure")
End If
End Sub

[John Wilson]

There is but it can only be done in edit mode. Is this where you are?

Something based on this:

Sub tableshader()
Dim otbl As Table
Dim i As Integer
Dim n As Integer
Dim r As Integer
Dim c As Integer
Dim sngComp As Single
Dim ptinput As Integer
Dim colstart As Integer
Dim rowstart As Integer
ptinput = InputBox("Enter the desired significant point difference")
' colstart = InputBox("Enter the column number for Total")
' rowstart = InputBox("Enter the row number that the data begins on")
On Error Resume Next
Set otbl = ActiveWindow.Selection.ShapeRange(1).Table
If Not otbl Is Nothing Then
For r = 1 To otbl.Rows.Count
For c = 1 To otbl.Columns.Count
If otbl.Cell(r, c).Selected Then
rowstart = r
colstart = c
Exit For
End If
Next
Next

With otbl
For n = rowstart To .Rows.Count
sngComp = Val(.Cell(n, colstart).Shape.TextFrame.TextRange)
For i = colstart + 1 To .Rows(n).Cells.Count
Select Case Val(.Cell(n, i).Shape.TextFrame.TextRange)
Case Is >= sngComp + ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(35, 80, 98)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0)
End If
Case Is <= sngComp - ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(127, 0, 15)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(0, 255, 0)
End If
End Select
Next i
Next n
End With
MsgBox ("Success")
Else
MsgBox ("Failure")
End If
End Sub

[macreator]

Thanks, John! This is perfect. Yep, I'm in Edit mode.

Here's how the code turned out:

Option Explicit
Sub tableshader()
Dim otbl As Table
Dim i As Integer
Dim n As Integer
Dim sngComp As Single
Dim ptinput As Integer
Dim colstart As Integer
Dim rowstart As Integer
ptinput = InputBox("Enter your desired significant point difference")
colstart = InputBox("Enter the column number for Total")
rowstart = InputBox("Enter the row number that the data begin on")
On Error Resume Next
Set otbl = ActiveWindow.Selection.ShapeRange(1).Table
If Not otbl Is Nothing Then
With otbl
For n = rowstart To .Rows.Count
sngComp = Val(.Cell(n, colstart).Shape.TextFrame.TextRange)
For i = colstart + 1 To .Rows(n).Cells.Count
Select Case Val(.Cell(n, i).Shape.TextFrame.TextRange)
Case Is >= sngComp + ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(35, 80, 98)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
End If
Case Is <= sngComp - ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(127, 0, 15)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
End If
End Select
Next i
Next n
End With
MsgBox ("Success")
Else
MsgBox ("Failure")
End If
End Sub


Question: This is more of a curiosity of mine and not all that critical. I've been playing around in VB and noticed the UserForm feature.

Could I theoretically combine the three input prompts into one UserForm?

I created a UserForm interface with three input boxes (for ptinput, rowstart and colstart) and then a Start button. Is it simple enough to use the inputs from the UserForm in the macro? For instance, would I replace colstart in the macro with UserForm1.colstart.Value or something to that effect? Or is it far more complex?

[macreator]

Nevermind -- I think I've got it.

In UserForm1 code I have:

Private Sub start_Click()
Dim otbl As Table
Dim i As Integer
Dim n As Integer
Dim sngComp As Single
Dim ptinput As Integer
Dim colstart As Integer
Dim rowstart As Integer
UserForm1.Show
ptinput = UserForm1.ptinputform.Value
ptinput = UserForm1.ptinputform.Value
colstart = UserForm1.colstartform.Value
rowstart = UserForm1.rowstartform.Value
On Error Resume Next
Set otbl = ActiveWindow.Selection.ShapeRange(1).Table
If Not otbl Is Nothing Then
With otbl
For n = rowstart To .Rows.Count
sngComp = Val(.Cell(n, colstart).Shape.TextFrame.TextRange)
For i = colstart + 1 To .Rows(n).Cells.Count
Select Case Val(.Cell(n, i).Shape.TextFrame.TextRange)
Case Is >= sngComp + ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(35, 80, 98)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
End If
Case Is <= sngComp - ptinput
If .Cell(n, i) Then
.Cell(n, i).Shape.Fill.ForeColor.RGB = RGB(127, 0, 15)
.Cell(n, i).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
End If
End Select
Next i
Next n
End With
MsgBox ("Success")
Else
MsgBox ("Failure")
End If
Unload Me
End Sub


And in the Module 1 code I have:

Option Explicit
Sub tableshader()
UserForm1.Show
End Sub


Meanwhile I've named the three input boxes in the UserForm ptinputform for ptinput, colstartform for colstart and rowstartform for rowstart.

The whole thing seems to work although I'm sure I could have missed something that might lead to instability.

Thanks again for your help! VB is pretty neat.