Функция книги Excel для удаления существующих диаграмм в ячейке и замены новой диаграммой - PullRequest
0 голосов
/ 16 апреля 2020

Я пытаюсь создать функцию 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

1 Ответ

0 голосов
/ 20 апреля 2020

Вот один подход, который может удовлетворить ваши потребности (урезать вашу функцию до самого необходимого)

Function InCellTimelineChart(TitleRange As Range, DataRange As Range) As String

    Dim chtNewChart As ChartObject
    Dim TargetCell As Range

    Set TargetCell = Application.Caller

    RemoveWrongChart TargetCell 'remove any chart which doesn't belong here

    On Error Resume Next
    Set chtNewChart = TargetCell.Parent.ChartObjects(TargetCell.Address)
    On Error GoTo 0

    If chtNewChart Is Nothing Then

        Set chtNewChart = TargetCell.Parent.ChartObjects.Add(TargetCell.Left + 2, TargetCell.Top + 2, _
                                      TargetCell.Width - 4, TargetCell.Height - 4)
        chtNewChart.Name = TargetCell.Address

    End If

End Function


Sub RemoveWrongChart(rng As Range)
    Dim co, i As Long
    For i = rng.Parent.ChartObjects.Count To 1 Step -1
        Set co = rng.Parent.ChartObjects(i)
        If co.TopLeftCell.Address = rng.Address And _
           co.Name <> rng.Address Then
            Debug.Print "Deleting " & co.Name & " from " & co.TopLeftCell.Address
            co.Delete
            Exit For
        End If
    Next i
End Sub

Не идеально, потому что для каждого вычисления вам нужно l oop через диаграммы и проверку их, но это обратная сторона этого через UDF.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...