Simple question but I don't manage to remove table cell borders in a table using VBA in PowerPoint.
I guess the following code should work but it doesn't do anything - any clues why?
No error message but the cells borders remain.
Sub RemoveCellsBorders()
Set oTbl = ActiveWindow.Selection.ShapeRange.Table
For X = 1 To oTbl.Columns.Count
For Y = 1 To oTbl.Rows.Count
If oTbl.cell(Y, X).Selected Then
oTbl.cell(Y, X).Borders(ppBorderTop).Visible = False
oTbl.cell(Y, X).Borders(ppBorderBottom).Visible = False
oTbl.cell(Y, X).Borders(ppBorderLeft).Visible = False
oTbl.cell(Y, X).Borders(ppBorderRight).Visible = False
End If
Next 'y
Next 'x
End Sub
Change the following code, then border will be removed, for unknown reason, visible = false is not working in ppt now and make sure you have select the table.
If oTbl.Cell(y, x).Selected Then
oTbl.Cell(y, x).Borders(ppBorderTop).Transparency = 1
oTbl.Cell(y, x).Borders(ppBorderBottom).Transparency = 1
oTbl.Cell(y, x).Borders(ppBorderLeft).Transparency = 1
oTbl.Cell(y, x).Borders(ppBorderRight).Transparency = 1
End If
Related
I want to change the same title of X-Y axis and format in many graphs at once using VBA.
I made code like below.
If I have 3 graphs, to change the second graph with the same X-Y axis titles and format, I copy and paste this code and change from ChartObjects(1) to ChartObjects(2), and also to change third graph, I also copy and paste this code again, and change as ChartObjects(3).
However, if I have 100 graphs, it seems impossible to copy and paste same codes 100 times, and change each ChartObjects.
Are there any methods to change X-Y axis titles in many graphs more easily?
Many thanks,
Sub axis()
Dim xytitle As chart
Set xytitle = Worksheets("graph").ChartObjects(1).chart
With xytitle.axes(xlCategory)
.HasTitle = True
.AxisTitle.Text = "Treatment"
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
With xytitle.axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Grain weight"
.MaximumScale = 60
.MajorUnit = 10
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
End Sub
I figured out the solution!! Thank you:)
Sub axis()
Dim xytitle As Chart
Dim i As Integer
For i = 1 To 4
Set xytitle = Worksheets("test").ChartObjects(i).Chart
With xytitle.Axes(xlCategory)
.HasTitle = True
.AxisTitle.Text = "Treatment"
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
With xytitle.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Grain weight"
.MaximumScale = 60
.MajorUnit = 10
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
Next
End Sub
I'm trying to make text in the data label of the chart with shadow effect (that shadow effect which you have at top of the PowerPoint menu), but I'm unable to make it work, dataLabels.shadow or dataLabels.font.shadow makes the frame shadowed, not the text.
I was googling a lot, I have found out this could be possible via TextFormat or TextFormat2 property, unfortunately I'm not able to access it for the text in the data label anyhow. My current code, lines after comment does not work:
For Each Shape In Slide.Shapes
If Shape.HasChart Then
Dim i As Integer
Dim v As Variant
Set pts = Shape.Chart.SeriesCollection(1).Points
For Each s In Shape.Chart.SeriesCollection
v = s.Values
If s.Name <> "XXX_XXX" Then
If v(pts.Count) >= 0.05 Then
s.Select
s.Points(pts.Count).Select
s.Points(pts.Count).ApplyDataLabels
s.DataLabels.Font.Color = s.Border.Color
s.DataLabels.Font.Size = 20
s.DataLabels.Font.Name = "Calibri"
's.DataLabels.Shadow = True
's.DataLabels.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel(pts.Count).TextFrame.TextRange.Font.Shadow = msoTrue
End If
End If
Next s
End If
Next Shape
If someone will have problems with simillar case I have found the answer :)
The shadow (ribbon like shadow) for data label text/value is done via TextRange2 property, but I was missing Format. Like this :
Dim tr As TextRange2
Set tr = s.DataLabels(pts.Count).Format.TextFrame2.TextRange
With tr.Font.Shadow
.OffsetX = 10
.OffsetY = 10
.Size = 1
.Blur = 4
.Transparency = 0.5
.Visible = True
End With
I have some code I have used to color excel charts with for quite a few years and it has worked well, (although there are likely better ways to do it). The charts contain 2 series, the first series with a value and the second with a goal. The goal does not get colored but the vba loops through the first series and colors according to hard coded goals in the vba.
The problem I have now is that I have added a chart that has a goal that can change month to month so having the hard coding doesn't work. How can I use the same theory but compare series 1 data directly to series 2 data to determine the color, (Case Is series 1 point > series 2 point, etc). I have tried a number of ways without success so any assistance would be greatly appreciated. below is the code for the proven technique.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
V = cht.Chart.SeriesCollection(1).Values
For Each p In cht.Chart.SeriesCollection(1).Points
Counter = Counter + 1
Select Case V(Counter)
'Case Is = 1
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
' Degree:=0.78
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 5
Case Is < 0.98
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 3
'Case Is < 0.98
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, _
' Degree:=0.38
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 6
Case Is <= 1
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 10
End Select
Next
Next
End Sub
Did you try something like:
Case Is > .SeriesCollection(2).Values()(Counter)
Also revised to get rid of some apparent redundancy (if need a loop and a counter variable, e.g., when looping several collections/arrays in parallel), it seems better IMO to just loop by index, rather than For Each _object_ with a separate counter.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
V = .SeriesCollection(1).Values
For Counter = 1 to.SeriesCollection(1).Points.Count
'Assign your Point object, if needed elsewhere
Set p = .SeriesCollection(1).Points(Counter)
Select Case V(Counter)
Case Is > .SeriesCollection(2).Values()(Counter)
'DO STUFF HERE.
'Add other cases if needed...
End Select
Next
End With
Next
End Sub
And unless you need the values in an array V for some other reason, this can be further reduced:
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim val1, val2
Dim Counter As Integer
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
For Counter = 1 to.SeriesCollection(1).Points.Count
'Assign your Point object, if needed elsewhere
Set p = .SeriesCollection(1).Points(Counter)
' extract specific point value to variables:
val1 = .SeriesCollection(1).Values()(Counter)
val2 = .SeriesCollection(2).Values()(Counter)
Select Case V(Counter)
Case val1 > val2
'DO STUFF HERE.
'Add other cases if needed...
End Select
Next
End With
Next
End Sub
Edited with final code, The gradient needed 2 refreshes to completely fill in, (I would have to hit another tab and then go back), so I added a loop to run the code through twice and now it updates perfect the first time. Hopefully this helps others. This allows for a completely dynamic chart. Again, thank you David.
Private Sub Worksheet_Activate()
Dim cht As Object
Dim p As Object
Dim V As Variant
Dim Counter As Integer
Dim L As Integer
For L = 1 To 2
For Each cht In ActiveSheet.ChartObjects
Counter = 0
With cht.Chart
V = cht.Chart.SeriesCollection(1).Values
For Counter = 1 To .SeriesCollection(1).Points.Count
Set p = .SeriesCollection(1).Points(Counter)
Select Case V(Counter)
'Blue Gradient
'Case Is = .SeriesCollection(2).Values()(Counter)
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
' Degree:=0.78
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 5
'Red Gradient
Case Is < .SeriesCollection(2).Values()(Counter)
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 3
'Yellow Gradient
'Case Is < .SeriesCollection(2).Values()(Counter)
'p.Shadow = False
'p.InvertIfNegative = False
'p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, _
' Degree:=0.38
'p.Fill.Visible = True
'p.Fill.ForeColor.SchemeColor = 6
'Green Gradient
Case Is >= .SeriesCollection(2).Values()(Counter)
p.Shadow = False
p.InvertIfNegative = False
p.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, _
Degree:=0.78
p.Fill.Visible = True
p.Fill.ForeColor.SchemeColor = 10
End Select
Next
End With
Next
Next L
End Sub
I am trying to change the text size in a textbox in Excel using VBA. I currently have the following code:
ActiveSheet.Shapes.Range(Array("textEnemy")).Visible = True
ActiveSheet.Shapes.Range(Array("textEnemy")).Select
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters
.Text = msg
For i = 1 To 15
.Font.Size = i * 10
Call WasteTime(50)
Next
End With
ActiveSheet.Shapes.Range(Array("textEnemy")).Visible = False
This code animates the text increasing in size, and then it disappears. The problem is that when I run this code the textbox is selected (there is a box around it). How can I achieve the same goal without selecting the textbox/showing the selection border around it?
Thanks!
As #findwindow says:
With ActiveSheet.Shapes.Range(Array("textEnemy"))
.Visible = True
With .ShapeRange(1).TextFrame2.TextRange.Characters
.Text = msg
For i = 1 To 15
.Font.Size = i * 10
Call WasteTime(50)
Next
End With
.Visible = False
End With
I found a solution. I had to set the textbox as a shape variable, and then adjust it.
Sub Animate(playerCode As Integer)
Dim i As Integer
Dim msg As String
Dim textBox As Shape
msg = "HIT!"
Set textBox = ActiveSheet.Shapes("textUser")
'Animate textbox
textBox.Visible = True
With textBox.TextFrame2.TextRange.Characters
.Text = msg
For i = 1 To 15
.Font.Size = i * 10
Call WasteTime(50)
Next
End With
textBox.Visible = False
End Sub
I have an exported Word document in which tables constructed by a database extractor have space between wrapped lines in cells that I can remove by selecting the table and using the paragraph dialog box, but there are many tables and I want to automate this.
All I have to do after selecting all the tables in the document (which I can do with VBA) is set Add Space Before and Add Space After both = 0, which I think, secretly also sets the AddSpaceBeforeAuto = AddSpaceAfterAuto = False.
So I started with a simple select subroutine:
Sub selecttables()
Dim mytable As Table
Application.ScreenUpdating = False
For Each mytable In ActiveDocument.Tables
mytable.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges (wdEditorEveryone)
ActiveDocument.DeleteAllEditableRanges (wdEditorEveryone)
Application.ScreenUpdating = True
End Sub
This works fine and leaves all my tables selected. All I want to do now is set the appropriate ParagraphFormat members to mimic my setting of these properties in the Paragraph Dialog to zero and false.
I tried three approaches:
1. Set the values globally for the Normal style (which all the tables use)
2. Set the values for each table as they are selected
3. Set the values on the total selection, after all the tables are selected.
When I do this manually after selecttables() executes, I am doing method 3.
The function below actually tries all three methods. I have selectively commented them out and discovered that no one of the methods works and doing all three doesn't help any.
I tried both "With Selection.Range.Style.ParagraphFormat" and "With Selection.Range.ParagraphFormat" for METHOD 3, but neither worked.
I would also like to set the table property, "Allow row to break across pages" to False (because, seriously, the default value of True is really dumb!) and can't figure how to do that either.
Here is the function:
Sub FixTables()
Dim mytable As Table
Dim i As Integer
Application.ScreenUpdating = False
' METHOD 1:
ActiveDocument.Styles("Normal").ParagraphFormat.Space1
ActiveDocument.Styles("Normal").ParagraphFormat.SpaceAfter = 0
ActiveDocument.Styles("Normal").ParagraphFormat.SpaceBefore = 0
ActiveDocument.Styles("Normal").ParagraphFormat.SpaceAfterAuto = False
ActiveDocument.Styles("Normal").ParagraphFormat.SpaceBeforeAuto = False
For Each mytable In ActiveDocument.Tables
' METHOD 2:
With mytable.Style.ParagraphFormat
.Space1
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
End With
mytable.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges (wdEditorEveryone)
ActiveDocument.DeleteAllEditableRanges (wdEditorEveryone)
'
With Selection.Style.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
End With
Application.ScreenUpdating = True
End Sub
I botched METHOD 3, by referring to the table reference I used in
METHOD 2 rather than the current Selection. Here is the correct answer:
Sub FixTables()
Dim mytable As Table
Application.ScreenUpdating = False
For Each mytable In ActiveDocument.Tables
mytable.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges (wdEditorEveryone)
ActiveDocument.DeleteAllEditableRanges (wdEditorEveryone)
With Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Application.ScreenUpdating = True
End Sub