0
このコードを記述しましたが、実行時にコードがチャートのタイトルを削除できません。ステップイン関数を使用してコードを手動で実行すると、完全に機能します。 私はの前にnewChart.HasTitle = False
行を試してみましたが、どちらもうまくいかないようです。何か案は?PowerPointでグラフのタイトルが削除されない
Sub InsertPieCharts()
Dim xl As Excel.Application
Dim aTB As Table
Dim aSL As Slide
Dim sh As Shape
Dim newChart As Chart
Dim aTX As Shape
Dim chartAreasWidth As Double, chartAreasHeight As Double, firstLeft As Double, chartsHSpace As Double, chartsLeft As Double, chartsTop As Double, firstTop As Double, chartsVSpace As Double, tHeight As Double, tWidth As Double, cWidth As Double, cHeight As Double
Dim r As Integer, c As Integer
'Measures
chartAreasWidth = 25 'cm
chartAreasHeight = 4.4 'cm
firstLeft = 3.13 'cm
firstTop = 13.01 'cm
tHeight = 1 'cm
tWidth = 1 'cm
cWidth = 2.5 'cm
cHeight = 2.2 'cm
'Objects
Set xl = CreateObject("Excel.Application")
Set aSL = ActivePresentation.Slides(16)
For Each sh In aSL.Shapes
If sh.HasTable Then
If sh.Table.Cell(1, 1).Shape.TextFrame2.TextRange = "Datatable" Then
Set aTB = sh.Table
Exit For
End If
End If
Next sh
chartsHSpace = xl.CentimetersToPoints(chartAreasWidth/(aTB.Columns.Count - 1))
chartsVSpace = xl.CentimetersToPoints(chartAreasHeight/(aTB.Rows.Count - 2))
chartsLeft = xl.CentimetersToPoints(firstLeft)
chartsTop = xl.CentimetersToPoints(firstTop)
tHeight = xl.CentimetersToPoints(tHeight)
tWidth = xl.CentimetersToPoints(tWidth)
cHeight = xl.CentimetersToPoints(cHeight)
cWidth = xl.CentimetersToPoints(cWidth)
For r = 3 To aTB.Rows.Count
For c = 2 To aTB.Columns.Count
Set newChart = aSL.Shapes.AddChart2(-1, xlPie, chartsLeft - (cWidth - tWidth)/2 + cWidth * (c - 2), chartsTop - (cHeight - tHeight)/2 + cHeight * (r - 3), cWidth, cHeight).Chart
With newChart.ChartData.Workbook.Sheets(1)
.Cells(1, 2).Value = ""
.Cells(2, 1).Value = "Fill"
.Cells(2, 2).Value = aTB.Cell(r, c).Shape.TextFrame2.TextRange * 1
.Cells(3, 2).Value = 100 - aTB.Cell(r, c).Shape.TextFrame2.TextRange
.Cells(3, 1).Value = "Unfill"
.Rows(4).Delete
.Rows(4).Delete
End With
newChart.ChartData.Workbook.Close
If newChart.HasTitle = True Then
newChart.HasTitle = False
End If
If newChart.HasLegend = True Then
newChart.HasLegend = False
End If
newChart.SeriesCollection(1).Points(1).Format.Fill.ForeColor.RGB = RGB(176, 176, 176)
newChart.SeriesCollection(1).Points(2).Format.Fill.Visible = False
Set aTX = aSL.Shapes.AddTextbox(msoTextOrientationHorizontal, chartsLeft + chartsHSpace * (c - 2), chartsTop + chartsVSpace * (r - 3), tWidth, tHeight)
aTX.TextFrame2.TextRange = aTB.Cell(r, c).Shape.TextFrame2.TextRange
aTX.TextFrame2.HorizontalAnchor = msoAnchorCenter
aTX.TextFrame2.VerticalAnchor = msoAnchorMiddle
aTX.AutoShapeType = msoShapeOval
If aTB.Cell(r, c).Shape.TextFrame2.TextRange > 89.5 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
aTX.Fill.ForeColor.RGB = RGB(47, 105, 151)
ElseIf aTB.Cell(r, c).Shape.TextFrame2.TextRange > 79.5 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
aTX.Fill.ForeColor.RGB = RGB(169, 202, 228)
ElseIf aTB.Cell(r, c).Shape.TextFrame2.TextRange > 69.5 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
aTX.Fill.ForeColor.RGB = RGB(255, 170, 170)
ElseIf aTB.Cell(r, c).Shape.TextFrame2.TextRange >= 0 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
aTX.Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
If aTB.Cell(r, c).Shape.TextFrame2.TextRange > 99.5 Then
aTX.TextFrame2.TextRange.Font.Size = 12
Else
aTX.TextFrame2.TextRange.Font.Size = 14
End If
aTX.Width = tWidth
aTX.Height = tHeight
Next c
Next r
End Sub