vba Excel宏修复折线图中重叠的数据标签

Excel macro to fix overlapping data labels in line chart

提问by Ron

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:

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

回答by chris neilsen

This task basically breaks down to two steps: accessthe Chartobject to get the Labels, and manipulatethe label positions to avoid overlap.

这个任务基本上分解为两个步骤：访问的Chart对象来获取Labels，并操纵的标签位置，避免重叠。

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.

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

Accessing the Labels

访问标签

This Subparses the chart and creates an array of Labelsfor each X point in turn

这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

Detect Overlaps

检测重叠

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

这调用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

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.

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

Note about Excel

Excel的注意事项

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.

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

回答by Danny Speranza

This macro will prevent overlapping labels on 2 line charts when data source is listed in two adjacent columns.

当数据源列在两个相邻列中时，此宏将防止 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

回答by Patrick

Allthough I agree that regular Excel formulas can't fix everything, I dislike VBA. There are several reasons for this, but the most important one is that chances are it will stop working with the next upgrade. I'm not saying you shouldn't use VBA at all, but only use it when necessary.

尽管我同意常规 Excel 公式不能解决所有问题，但我不喜欢 VBA。造成这种情况的原因有很多，但最重要的一个原因是它可能会在下一次升级时停止工作。我并不是说你根本不应该使用 VBA，而是只在必要时使用它。

Your question is a good example of a need where VBA isn't necessary.. "OK" you say, "but then how do I fix this problem?" Feel lucky and click this link to my answer to a related question here.

你的问题是不需要 VBA 的一个很好的例子..“好的”你说，“但是我该如何解决这个问题？” 感觉很幸运，点击这个链接到我对相关问题的回答这里。

What you'll find out in the link is, how you can measure your charts' exact grid. When your x-axis crosses at 0, you'll only need the maximum Y-axis label for that. You're only half way there now, cause your specific problem isn't solved yet. Here's how I would proceed:

您将在链接中发现的是，如何测量图表的精确网格。当您的 x 轴在 0 处交叉时，您只需要最大的 Y 轴标签。您现在只完成了一半，因为您的具体问题尚未解决。这是我将如何进行：

First measure how high your labels are compared to the height of your chart. This will need some trial and error, but shouldnt be very difficult. If your chart can stack 20 labels without overlapping, this number would be 0.05 for example.

首先测量您的标签与图表高度相比的高度。这将需要一些试验和错误，但不应该很困难。如果您的图表可以在不重叠的情况下堆叠 20 个标签，则该数字例如为 0.05。

Next determine if and where any of the labels would overlap. This is quite easy, cause all you need to do is find out where numbers are too close to each other (within the 0.05 range in my example).

接下来确定任何标签是否以及在哪里重叠。这很容易，因为您需要做的就是找出数字彼此太接近的位置（在我的示例中在 0.05 范围内）。

Use some boolean tests or for all I care IF formulas to find out. The result you're after is a table with the answers for each of the series (except the first one). Don't be afraid to duplicate that table again for the next step: creating the new chart input.

使用一些布尔测试或所有我关心的 IF 公式来找出答案。您所追求的结果是一个表格，其中包含每个系列的答案（第一个除外）。不要害怕在下一步中再次复制该表：创建新的图表输入。

There are several ways to create the new chart, but here's the one I'd choose. For each of the series create three lines. One is the actual line, the other two are the invisible lines with just the data labels. For each of the lines there is one invisible line with just the regular labels. Those all use the same alignment. Each extra invisible line has a different allignment for the labels. You won't need one for your first series, but for the second one the label would be to the right, the third one beneath and the fourth one to the left (for example).

有多种方法可以创建新图表，但这是我选择的一种。为每个系列创建三行。一个是实际线，另外两个是只有数据标签的不可见线。对于每一行，有一条不可见的线，只有常规标签。这些都使用相同的对齐方式。每条额外的不可见线都有不同的标签对齐方式。您的第一个系列不需要一个，但对于第二个系列，标签将在右侧，第三个在下方，第四个在左侧（例如）。

When none of the data labels overlap only the first invisible lines (with regular alignment) need to show the values. When labels do overlap, the corresponding extra invisible line should take over on that point and show its label. Of course the first invisible line should not show one there.

当没有数据标签重叠时，只有第一条不可见线（具有规则对齐）需要显示值。当标签确实重叠时，相应的额外不可见线应接管该点并显示其标签。当然，第一条不可见的线不应该在那里显示。

When all four labels overlap at the same x-axis value, you should see the first basic invisible line's label and the three extra invisible lines' labels. This should work for your example chart, cause there is enough room to move to labels to the left and right. Personally I'd stick with just the minimum and the maximum label at an overlapping point, cause the fact it overlaps shows the values are pretty close to each other in the first place..

当所有四个标签在相同的 x 轴值处重叠时，您应该看到第一个基本不可见线的标签和三个额外不可见线的标签。这应该适用于您的示例图表，因为有足够的空间可以向左和向右移动标签。就我个人而言，我只会在重叠点使用最小和最大标签，因为它重叠的事实表明这些值首先彼此非常接近。

I hope this helped you,

我希望这对你有帮助

Greetings,

你好，

Patrick

帕特里克

回答by tobias

@chris neilsen Could you test your solution on Excel 2007? When I cast the objects to DataLabel class, it looks like the .Width property has been removed from the class. (Sorry, I was not permitted to comment on your reply)

@chris neilsen 你能在 Excel 2007 上测试你的解决方案吗？当我将对象转换为 DataLabel 类时，看起来 .Width 属性已从类中删除。（对不起，我没有被允许对你的回复发表评论）

Maybe one thing to add from below forum is to temporary adjust position of label: http://www.ozgrid.com/forum/showthread.php?t=90439"you get close width or height value of the data label by forcing the label off of the chart and comparing the reported left/top value to that of the chartarea inside width/height."

也许从下面论坛添加的一件事是临时调整标签的位置：http: //www.ozgrid.com/forum/showthread.php?t= 90439“通过强制标签关闭图表并将报告的左侧/顶部值与宽度/高度内的图表区域的值进行比较。”

Based on this, please move v(i).Width & v(j).Width to a variables sng_vi_Width & sng_vj_Width and add these lines

基于此，请将 v(i).Width & v(j).Width 移动到变量 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