Excel宏修复折线图中重叠的数据标签 [英] Excel macro to fix overlapping data labels in line chart

问题描述

我正在搜索/尝试制作一个宏来固定带有一个或多个系列集合的折线图中数据标签的位置，以便它们不会相互重叠.

I am searching/trying to make a macro to fix the position of data labels in a line chart with one or multiple series collections so that they will not overlap each other.

我正在为我的宏考虑一些方法，但当我尝试实现它时，我明白这对我来说太难了，我很头疼.

I was thinking of some ways for my macro but when I try to make it I understand that this is way too hard for me and I get headache.

有什么我错过的吗?你知道这样的宏吗?

Is there anything that I missed? Do you know about such a macro?

这是一个带有重叠数据标签的示例图表:

Here's an example chart with overlapped data labels:

这是我手动修复数据标签的示例图表:

Here's an example chart where I manually fixed the data labels:

推荐答案

这个任务基本上分为两个步骤:访问Chart 对象以获取标签，并操纵标签位置以避免重叠.

This task basically breaks down to two steps: access the Chart object to get the Labels, and manipulate the label positions to avoid overlap.

对于给定的样本，所有系列都绘制在一个共同的 X 轴上，并且 X 值足够分散，标签在此维度上不会重叠.因此，所提供的解决方案仅依次处理每个 X 点的标签组.

For the sample given all series are plotted on a common X-axis and the X values are sufficiently spread that labels don't overlap in this dimension. Therefore the solution offered only deals with groups of labels for each X point in turn.

这个Sub解析图表并依次为每个X点创建一个Labels数组

This Sub parses the chart and creates an array of Labels for each X point in turn

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

检测重叠

这会调用带有 Labels 数组的 AdjustLables.这些标签需要检查重叠

Detect Overlaps

This calls AdjustLables with an array of Labels. These labels need to be checked for overlap

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

移动标签

当检测到重叠时，您需要一种策略来移动一个或两个标签而不产生另一个重叠.
这里有很多可能性，你已经给出了足够的细节来判断你的要求.

Moving Labels

When an overlap is detected you need a strategy that move one or both labels without creating another overlap.
There are many possibilities here, you havn'e given sufficient details to judge your requirements.

要使这种方法起作用，您需要具有 DataLabel.Width 和 DataLabel.Height 属性的 Excel 版本.2003 SP2 版本(可能还有更早的版本)没有.

For this approach to work you need a version of Excel that has DataLabel.Width and DataLabel.Height properties. Version 2003 SP2 (and, presumably, earlier) does not.

这篇关于Excel宏修复折线图中重叠的数据标签的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！