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

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

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

что я пропустил? Вы знаете о таком макро?

вот пример диаграммы с наложением данных этикетки:

enter image description here

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

enter image description here

6
charts excel excel-2007 excel-vba vba

4 ответов

эта задача в основном распадается на два шага: открыть на 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.Ширина и DataLabel.Свойство height. Версия 2003 SP2 (и, предположительно, ранее) этого не делает.

17

этот макрос предотвратит наложение меток на 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
1

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

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

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

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

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

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

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

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

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

надеюсь, это помогло ты,

с приветом,

Патрик

-1

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

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

исходя из этого, переместите v(i).Ширина & 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
-1