Excel 2007，如何避免散点图数据点重叠

Question

我有一本工作簿和以下表格 仪表板，IImpactchart。

仪表板，包含候选人名称、影响力参考和影响力参考

候选人 |影响 |影响

具有

的值

候选人1，影响值=3，影响值=2

候选2，影响值=3，影响值=2

在图表中，我们需要在(3,2)的坐标中显示对应的行号。它仅针对单个候选人进行绘图。如果我们有更多具有相同值的候选者，则数据点将重叠在另一个之上。我们如何移动用逗号分隔的数据点？或任何其他方式。

附上图表 Please click here to see the Chart output

需要图表 Please click here to see the required chart

使用VBA

Dim Counter As Integer, ChartName As String, xVals As String
Application.ScreenUpdating = False
Dim c As ChartObject
Set c = Sheets("IImpactchart").ChartObjects("Chart 1")
c.Activate
xVals = ActiveChart.SeriesCollection(1).Formula
xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
  Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)

Do While Left(xVals, 1) = ","
  xVals = Mid(xVals, 2)
Loop

For Counter = 1 To Range(xVals).Cells.Count
 If (Range(xVals).Cells(Counter, 1).Offset(0, -1).Value = 0) Then
     Exit Sub
 End If

 ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _
     True
 ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Text = Counter + 5

Next Counter

（计数器增加 5 以获得正确的行号） - 它的工作

现在我需要解决重叠问题。

帮助表示赞赏.. 谢谢

Answer 1

假设您当前的代码有效并且唯一的问题是重叠，下面的代码应该可以解决您的问题。

此解决方案涉及使用名为LabelArray 的数组，该数组存储第一个点的点号以占据网格上的点。然后，它不会为新点创建新标签，而只是添加到第一个点的现有标签。

Sub LabelsNoOverlap()

    Dim Counter As Integer, ChartName As String, xVals As String, yVals As String
    Application.ScreenUpdating = False

    Dim c As ChartObject
    Set c = Sheets("IImpactchart").ChartObjects("Chart 2")
    c.Activate

    'Find address of the X values
    xVals = ActiveChart.SeriesCollection(1).Formula
    xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
        Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
    xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)

    'Not sure why this loop from your code is useful, but let's leave it.
    Do While Left(xVals, 1) = ","
        xVals = Mid(xVals, 2)
    Loop

    'Find address of the Y values
    yVals = ActiveChart.SeriesCollection(1).Formula
    yVals = Mid(yVals, InStr(InStr(yVals, ","), yVals, _
        Mid(Left(yVals, InStr(yVals, "!") - 1), 9)))
    yVals = Right(yVals, Len(yVals) - InStr(yVals, ","))
    yVals = Left(yVals, InStr(InStr(yVals, "!"), yVals, ",") - 1)

    'Again, not sure why this loop from your code is useful, but let's leave it.
    Do While Left(yVals, 1) = ","
        yVals = Mid(yVals, 2)
    Loop

    Dim DimY As Long, DimX As Long
    DimY = 10
    DimX = 10

    Dim LabelArray() As Long
    ReDim LabelArray(1 To DimX, 1 To DimY)

    Dim src As Series, pts As Points
    Set src = ActiveChart.SeriesCollection(1)
    Set pts = src.Points

    'Clear labels
    src.HasDataLabels = False

    For Counter = 1 To Range(xVals).Cells.Count
        If (Range(xVals).Cells(Counter, 1).Offset(0, -1).Value = 0) Then
            Exit Sub
        End If
        Dim xCoord As Long, yCoord As Long
        xCoord = Range(xVals).Cells(Counter, 1).Value2
        yCoord = Range(yVals).Cells(Counter, 1).Value2

        If LabelArray(xCoord, yCoord) = 0 Then 'No overlap
            LabelArray(xCoord, yCoord) = Counter
            pts(Counter).HasDataLabel = True
            pts(Counter).DataLabel.Text = Counter + 5
        Else 'Overlap
            pts(LabelArray(xCoord, yCoord)).DataLabel.Text = _
                pts(LabelArray(xCoord, yCoord)).DataLabel.Text & "," & Counter + 5
        End If
    Next Counter

    Application.ScreenUpdating = True

End Sub

请注意，只要您的 X 和 Y 值介于 1 到 10 之间，代码就可以工作。您还可以通过更改 DimX 和 DimY 的值来更改上限。

另外，我应该提一下这段代码有局限性：

• 在当前版本中，它无法处理 X 和 Y 值等于或小于 0 的整数。
• 解析 SERIES 公式的方法对于某些字符（例如工作表名称中的逗号）的存在并不可靠（是的，出于某种原因允许这样做）。
• 指定代码的方式假定数据系列是垂直方向的。也许，对于更通用的解决方案，您必须测试数据的方向，或者您可以使用 src.XValues 和 src.Values（对于 Y 值）来实现一些东西，它返回数组而不是范围。