Макрос Excel для исправления перекрывающихся меток данных в линейном графике

Question

Я ищу / пытаюсь создать макрос, чтобы исправить положение меток данных в линейном графике с одной или несколькими коллекциями серий, чтобы они не перекрывали друг друга.

Я думал о некоторых способах макроса, но когда я пытаюсь его сделать, я понимаю, что это слишком сложно для меня, и у меня болит голова.

Есть что-нибудь, что я пропустил? Вы знаете о таком макросе?

Вот пример диаграммы с перекрывающимися метками данных:

Вот пример диаграммы, где я вручную исправил метки данных:

Answer 1

Эта задача в основном разбита на два этапа: доступ Chart объект для получения Labels и манипулирование позициями меток, чтобы избежать наложения.

Для данного образца все серии нанесены на общую ось X, а значения X достаточно разбросаны, чтобы метки не перекрывались в этом измерении. Поэтому предлагаемое решение имеет дело только с группами меток для каждой точки X по очереди.

Доступ к ярлыкам

Этот Sub анализирует диаграмму и создает массив Labels для каждой точки X по очереди

Sub MoveLabels()
    Dim sh As Worksheet
    Dim ch As Chart
    Dim sers As SeriesCollection
    Dim ser As Series
    Dim i As Long, pt As Long
    Dim dLabels() As DataLabel

    Set sh = ActiveSheet
    Set ch = sh.ChartObjects("Chart 1").Chart
    Set sers = ch.SeriesCollection

    ReDim dLabels(1 To sers.Count)
    For pt = 1 To sers(1).Points.Count
        For i = 1 To sers.Count
            Set dLabels(i) = sers(i).Points(pt).DataLabel
        Next
        AdjustLabels dLabels  ' This Sub is to deal with the overlaps
    Next
End Sub

Обнаружение перекрытий

Это вызывает AdjustLables с массивом Labels. Эти этикетки должны быть проверены на совпадение

Sub AdjustLabels(ByRef v() As DataLabel)
    Dim i As Long, j As Long

    For i = LBound(v) To UBound(v) - 1
    For j = LBound(v) + 1 To UBound(v)
        If v(i).Left <= v(j).Left Then
            If v(i).Top <= v(j).Top Then
                If (v(j).Top - v(i).Top) < v(i).Height _
                And (v(j).Left - v(i).Left) < v(i).Width Then
                    ' Overlap!

                End If
            Else
                If (v(i).Top - v(j).Top) < v(j).Height _
                And (v(j).Left - v(i).Left) < v(i).Width Then
                    ' Overlap!

                End If
            End If
        Else
            If v(i).Top <= v(j).Top Then
                If (v(j).Top - v(i).Top) < v(i).Height _
                And (v(i).Left - v(j).Left) < v(j).Width Then
                    ' Overlap!

                End If
            Else
                If (v(i).Top - v(j).Top) < v(j).Height _
                And (v(i).Left - v(j).Left) < v(j).Width Then
                    ' Overlap!

                End If
            End If
        End If
    Next j, i
End Sub

Перемещение меток

При обнаружении перекрытия вам нужна стратегия, которая перемещает одну или обе метки без создания другого перекрытия.
Здесь есть много возможностей, вы предоставили достаточно деталей, чтобы оценить ваши требования.

Примечание об Excel

Чтобы этот подход работал, вам нужна версия Excel, которая имеет свойства DataLabel.Width и DataLabel.Height. Версия 2003 SP2 (и, по-видимому, более ранняя версия) этого не делает.

Answer 2

Этот макрос предотвратит перекрывающиеся метки на двухстрочных диаграммах, если источник данных указан в двух соседних столбцах.

Attribute VB_Name = "DataLabel_Location"
Option Explicit


Sub DataLabel_Location()
'
'
' *******move data label above or below line graph depending or other line graphs in same chart***********

Dim Start As Integer, ColStart As String, ColStart1 As String
Dim RowStart As Integer, Num As Integer, x As Integer, Cell As Integer, RowEnd As Integer

Dim Chart As String, Value1 As Single, String1 As String


Dim Mycolumn As Integer
Dim Ans As String
Dim ChartNum As Integer



   Ans = MsgBox("Was first data point selected?", vbYesNo)
    Select Case Ans
    Case vbNo
    MsgBox "Select first data pt then restart macro."
    Exit Sub

    End Select

     On Error Resume Next


ChartNum = InputBox("Please enter Chart #")
    Chart = "Chart " & ChartNum
ActiveSheet.Select

ActiveCell.Select


RowStart = Selection.row
ColStart = Selection.Column
ColStart1 = ColStart + 1
ColStart = ColNumToLet(Selection.Column)
RowEnd = ActiveCell.End(xlDown).row
ColStart1 = ColNumToLet(ActiveCell.Offset(0, 1).Column)

Num = RowEnd - RowStart + 1


With ThisWorkbook.ActiveSheet.Select
    ActiveSheet.ChartObjects(Chart).Activate
    ActiveChart.SeriesCollection(1).ApplyDataLabels
    ActiveChart.SeriesCollection(2).ApplyDataLabels
End With

    For x = 1 To Num

           Value1 = Range(ColStart & RowStart).Value
           String1 = Range(ColStart1 & RowStart).Value


        If Value1 = 0 Then
            ActiveSheet.ChartObjects(Chart).Activate
            ActiveChart.SeriesCollection(1).DataLabels(x).Select
            Selection.Delete
        End If

        If String1 = 0 Then
            ActiveSheet.ChartObjects(Chart).Activate
            ActiveChart.SeriesCollection(2).DataLabels(x).Select
            Selection.Delete
        End If


        If Value1 <= String1 Then



            ActiveSheet.ChartObjects("Chart").Activate

            ActiveChart.SeriesCollection(1).DataLabels(x).Select
            Selection.Position = xlLabelPositionBelow
            ActiveChart.SeriesCollection(2).DataLabels(x).Select
            Selection.Position = xlLabelPositionAbove




        Else
            ActiveSheet.ChartObjects("Chart").Activate
            ActiveChart.SeriesCollection(1).DataLabels(x).Select
            Selection.Position = xlLabelPositionAbove
            ActiveChart.SeriesCollection(2).DataLabels(x).Select
            Selection.Position = xlLabelPositionBelow

        End If
            RowStart = RowStart + 1
    Next x

End Sub

'
' convert column # to column letters
'
Function ColNumToLet(Mycolumn As Integer) As String
  If Mycolumn > 26 Then
    ColNumToLet = Chr(Int((Mycolumn - 1) / 26) + 64) & Chr(((Mycolumn - 1) Mod 26) + 65)
  Else
    ColNumToLet = Chr(Mycolumn + 64)
  End If
End Function

Answer 3

@ chris neilsen Не могли бы вы проверить свое решение в Excel 2007?Когда я приводил объекты к классу DataLabel, похоже, что свойство .Width было удалено из класса.(Извините, мне не разрешили комментировать ваш ответ)

Возможно, что-то, что можно добавить из-под форума, - это временно отрегулировать положение метки: http://www.ozgrid.com/forum/showthread.php?t=90439 "вы получаете близкое значение ширины или высотыметка данных, вытеснив метку с графика и сравнив сообщаемое левое / верхнее значение со значением хартареи внутри width / height. "

Исходя из этого, переместите v (i) .Width & v(j). Ширина к переменной sng_vi_Width & sng_vj_Width и добавьте эти строки

With v(i)
 sngOriginalLeft = .Left 
 .Left = .Parent.Parent.Parent.Parent.ChartArea.Width 
 sng_vi_Width = .Parent.Parent.Parent.Parent.ChartArea.Width - .Left 
 .Left = sngOriginalLeft 
End With
With v(j)
 sngOriginalLeft = .Left 
 .Left = .Parent.Parent.Parent.Parent.ChartArea.Width 
 sng_vj_Width = .Parent.Parent.Parent.Parent.ChartArea.Width - .Left 
 .Left = sngOriginalLeft 
End With

Answer 4

Несмотря на то, что я согласен, что обычные формулы Excel не могут исправить все, мне не нравится VBA. Для этого есть несколько причин, но самая важная из них заключается в том, что, скорее всего, он перестанет работать со следующим обновлением. Я не говорю, что вам вообще не следует использовать VBA, а используйте его только при необходимости.

Ваш вопрос является хорошим примером необходимости, когда VBA не требуется ... "Хорошо", вы говорите: "Но тогда как мне решить эту проблему?" Если вам повезет, нажмите на эту ссылку, чтобы ответить на соответствующий вопрос здесь .

В ссылке вы узнаете, как вы можете измерить точную сетку ваших графиков. Когда ваша ось X пересекает 0, вам понадобится только максимальная метка оси Y для этого. Вы сейчас только на полпути, потому что ваша конкретная проблема еще не решена. Вот как бы я поступил:

Сначала измерьте, насколько высоки ваши метки по сравнению с высотой вашего графика. Это потребует проб и ошибок, но не должно быть очень сложным. Если ваша диаграмма может складывать 20 меток без наложения, это число будет, например, 0,05.

Затем определите, будут ли перекрываться какие-либо метки. Это довольно легко, потому что все, что вам нужно сделать, это выяснить, где числа находятся слишком близко друг к другу (в пределах диапазона 0,05 в моем примере).

Используйте некоторые булевы тесты или, если хотите, все формулы IF, чтобы узнать. В результате вы получите таблицу с ответами для каждой серии (кроме первой). Не бойтесь снова продублировать эту таблицу для следующего шага: создания нового ввода диаграммы.

Есть несколько способов создать новую диаграмму, но вот тот, который я бы выбрал. Для каждой серии создайте три строчки. Одна - это фактическая строка, две другие - невидимые строки с метками данных. Для каждой из строк есть одна невидимая строка с обычными метками. Все они используют одинаковое выравнивание. Каждая дополнительная невидимая строка имеет различное выравнивание для меток. Вам не понадобится один для первой серии, но для второй метка будет справа, третья снизу и четвертая слева (например).

Когда ни одна из меток данных не перекрывается, только первые невидимые строки (с регулярным выравниванием) должны показывать значения. Когда метки перекрываются, соответствующая дополнительная невидимая линия должна занять место в этой точке и показать ее метку. Конечно, первая невидимая строка не должна показывать ее там.

Когда все четыре метки перекрываются с одним и тем же значением оси x, вы должны увидеть метку первой основной невидимой линии и метки трех дополнительных невидимых линий. Это должно работать для вашего примера диаграммы, потому что есть достаточно места, чтобы перейти к меткам слева и справа. Лично я бы придерживался только минимальной и максимальной метки в точке перекрытия, потому что факт, что она перекрывается, показывает, что значения довольно близки друг к другу, во-первых ..

Надеюсь, это вам помогло,

Привет,

Patrick