Я пытаюсь создать функцию Excel, которую можно использовать для генерации диаграммы непосредственно в ячейке, в которой написана функция. У меня все работает, кроме одного раздражения в этом; когда я пытаюсь скопировать функцию из одной ячейки в другую, диаграмма идет вместе с ней, и вставленная ячейка генерирует собственную диаграмму поверх скопированной диаграммы. Поэтому каждый раз, когда я копирую функцию в новые ячейки, у меня появляются дополнительные (ошибочные) диаграммы, которые могут повлечь за собой путаницу. Есть ли способ проверить только ячейку, в которой находится функция, и попросить ее удалить все существующие диаграммы перед созданием собственной диаграммы?
Function InCellTimelineChart(TitleRange As Range, DataRange As Range) As String
On Error GoTo Fail
Dim chtNewChart As ChartObject
Dim TargetCell As Range
Dim SeriesCount As Integer
Dim i As Integer
Dim TitleText As String
'Preliminary data input processing
If TitleRange.Cells.Count <> DataRange.Cells.Count Then
InCellTimelineChart = "Mismatch in data and title counts."
Exit Function
End If
If TitleRange.Rows.Count > 1 And TitleRange.Columns.Count > 1 Then
InCellTimelineChart = "Titles can be selected within a single row or column only."
Exit Function
End If
If DataRange.Rows.Count > 1 And DataRange.Columns.Count > 1 Then
InCellTimelineChart = "Data can be selected within a single row or column only."
Exit Function
End If
If TitleRange.Rows.Count = 1 Then
SeriesCount = TitleRange.Columns.Count
Else
SeriesCount = TitleRange.Rows.Count
End If
'Main Function
Set TargetCell = Application.Caller
On Error Resume Next
Set chtNewChart = TargetCell.Parent.ChartObjects(TargetCell.Address)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Fail
Else
chtNewChart.Delete
On Error GoTo Fail
End If
Set chtNewChart = TargetCell.Parent.ChartObjects.Add(TargetCell.Left + 2, TargetCell.Top + 2, TargetCell.Width - 4, TargetCell.Height - 4)
chtNewChart.Name = TargetCell.Address
chtNewChart.Chart.ChartType = xlXYScatter
chtNewChart.Chart.ClearToMatchStyle
chtNewChart.Chart.ChartStyle = 343
For i = 1 To SeriesCount
TitleText = "="""
TitleText = TitleText & Replace(TitleRange.Item(i), """", "")
TitleText = TitleText & """"
If IsDate(DataRange.Item(i)) Then
chtNewChart.Chart.SeriesCollection.NewSeries
chtNewChart.Chart.FullSeriesCollection(i).Name = TitleText
chtNewChart.Chart.FullSeriesCollection(i).XValues = "=" & TargetCell.Parent.Name & "!" & DataRange.Item(i).Address
chtNewChart.Chart.FullSeriesCollection(i).Values = "={0}"
chtNewChart.Chart.FullSeriesCollection(i).ApplyDataLabels
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.ShowSeriesName = True
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.ShowValue = False
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.ShowCategoryName = True
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.Position = xlLabelPositionAbove
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.Orientation = xlUpward
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.Format.TextFrame2.Orientation = msoTextOrientationUpward
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.Format.TextFrame2.WordWrap = msoFalse
chtNewChart.Chart.FullSeriesCollection(i).DataLabels.ShowValue = False
With chtNewChart.Chart.FullSeriesCollection(i).Format.Shadow
.Type = msoShadow21
.Visible = msoTrue
.Style = msoShadowStyleOuterShadow
.Blur = 4.5
.OffsetX = 9.1848509936E-17
.OffsetY = 1.5
.RotateWithShape = msoFalse
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0.3700000048
.Size = 100
End With
chtNewChart.Chart.FullSeriesCollection(i).Format.Fill.Visible = msoTrue
End If
Next i
chtNewChart.Chart.Axes(xlValue).Delete
chtNewChart.Chart.Axes(xlValue).MajorGridlines.Delete
chtNewChart.Chart.Axes(xlCategory).MajorGridlines.Delete
chtNewChart.Chart.Legend.Delete
chtNewChart.Chart.Axes(xlCategory).TickLabelPosition = xlNone
With chtNewChart.Chart.FullSeriesCollection(5).DataLabels.Format.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0
.Solid
End With
Exit Function
Fail:
Debug.Print "Error in InCellTimelineChart: " & vbCrLf & Err.Number & vbCrLf & Err.Description
InCellTimelineChart = Err.Number & vbCrLf & Err.Description
chtNewChart.Delete
End Function