Question

所以过去一周我一直在研究这个问题。虽然它不能创造奇迹，但我可以说我有一个非常好的结果： Before and After Before and After in a more serious chart 我只是想把这个代码放在那里，为所有像我一样的穷人寻找某种vba宏，帮助他们避免散点图中的标签重叠，因为在对这个主题进行研究时，我无法找到任何有用的东西。

Answer 1

Const PIXEL_TO_POINT_RATIO As Double = 0.72 '1 Pixel = 72/96*1 Point
Const tStep As Double = 0.1
Const rStep As Double = 0.1
Dim pCount As Integer

Sub ExampleMain()

        RearrangeScatterLabels Sheet5 

        RearrangeScatterLabels Sheet25

End Sub

Sub RearrangeScatterLabels(sht As Worksheet)
    Dim plot As Chart
    Dim sCollection As SeriesCollection
    Dim dLabels() As DataLabel
    Dim dPoints() As Point
    Dim xArr(), yArr(), stDevX, stDevY As Double
    Dim x0, x1, y0, y1 As Double
    Dim temp() As Double
    Dim theta As Double
    Dim r As Double
    Dim isOverlapped As Boolean
    Dim safetyNet, validEntry, currentPoint As Integer

    Set plot = sht.ChartObjects(1).Chart 'XY chart (scatter plot)
    Set sCollection = plot.SeriesCollection 'All points and labels
    safetyNet = 1
    pCount = (sCollection.Count - 1)

    ReDim dLabels(1 To 1)
    ReDim dPoints(1 To 1)
    ReDim xArr(1 To 1)
    ReDim yArr(1 To 1)

    For pt = 1 To sCollection(1).Points.Count
        For i = 1 To pCount
            If sCollection(i).Points.Count <> 0 Then
                'Dynamically expand the arrays
                validEntry = validEntry + 1
                If validEntry <> 1 Then
                    ReDim Preserve dLabels(1 To UBound(dLabels) + 1)
                    ReDim Preserve dPoints(1 To UBound(dPoints) + 1)
                    ReDim Preserve xArr(1 To UBound(xArr) + 1)
                    ReDim Preserve yArr(1 To UBound(yArr) + 1)
                End If

                Set dLabels(i) = sCollection(i).Points(pt).DataLabel 'Store all label objects
                Set dPoints(i) = sCollection(i).Points(pt)           'Store all point objects
                temp = getElementDimensions(, dPoints(i))
                xArr(i) = temp(0) 'Store all points x values
                yArr(i) = temp(2) 'Store all points y values
            End If
        Next
    Next

    If UBound(dLabels) < 2 Then Exit Sub

    pCount = UBound(dLabels)
    stDevX = Application.WorksheetFunction.StDev(xArr) 'Get standard deviation for x
    stDevY = Application.WorksheetFunction.StDev(yArr) 'Get standard deviation for y
    If stDevX = 0 Then stDevX = 1
    If stDevY = 0 Then stDevY = 1
    r = 0

    For currentPoint = 1 To pCount
        theta = Rnd * 2 * Application.WorksheetFunction.Pi()
        x0 = xArr(currentPoint)
        y0 = yArr(currentPoint)
        x1 = xArr(currentPoint)
        y1 = yArr(currentPoint)
        isOverlapped = True

        Do Until Not isOverlapped
            safetyNet = safetyNet + 1

            If safetyNet < 500 Then
                If Not checkForOverlap(dLabels(currentPoint), dLabels, dPoints, plot) Then
                    'No label is within bounds and not overlapping
                    isOverlapped = False
                    r = 0
                    theta = Rnd * 2 * Application.WorksheetFunction.Pi()
                    safetyNet = 1
                Else
                    'Move label so it does not overlap
                    theta = theta + tStep
                    r = r + rStep * tStep / (2 * Application.WorksheetFunction.Pi())
                    x1 = x0 + stDevX * r * Cos(theta)
                    y1 = y0 + stDevY * r * Sin(theta)
                    dLabels(currentPoint).Left = x1
                    dLabels(currentPoint).Top = y1
                End If
            Else
                safetyNet = 1
                Exit Do
            End If
        Loop
    Next
End Sub

Function checkForOverlap(ByRef dLabel As DataLabel, ByRef dLabels() As DataLabel, ByRef dPoints() As Point, ByRef dChart As Chart) As Boolean
    checkForOverlap = False 'Return false by default

    'Detect label going over chart area
    If detectOverlap(dLabel, , , dChart) Then
        checkForOverlap = True
        Exit Function
    End If

    'Detect labels overlap
    For i = 1 To pCount
        If Not dLabel.Left = dLabels(i).Left Then
            If detectOverlap(dLabel, dLabels(i)) Then
                checkForOverlap = True
                Exit Function
            End If
        End If
    Next

    'Detect label overlap with point
    For i = 1 To pCount
        If detectOverlap(dLabel, , dPoints(i)) Then
            checkForOverlap = True
            Exit Function
        End If
    Next
End Function

Function getElementDimensions(Optional dLabel As DataLabel, Optional dPoint As Point, Optional dChart As Chart) As Double()
    'Get element dimensions and compensate slack
    Dim eDimensions(3) As Double

    'Working in IV quadrant
    If dPoint Is Nothing And dChart Is Nothing Then
        'Get label dimensions and compensate padding
        eDimensions(0) = dLabel.Left + PIXEL_TO_POINT_RATIO * 3                'Left
        eDimensions(1) = dLabel.Left + dLabel.Width - PIXEL_TO_POINT_RATIO * 3 'Right
        eDimensions(2) = dLabel.Top + PIXEL_TO_POINT_RATIO * 6                 'Top
        eDimensions(3) = dLabel.Top + dLabel.Height - PIXEL_TO_POINT_RATIO * 3 'Bottom
    End If
    If dLabel Is Nothing And dChart Is Nothing Then
        'Get point dimensions
        eDimensions(0) = dPoint.Left - PIXEL_TO_POINT_RATIO * 5 'Left
        eDimensions(1) = dPoint.Left + PIXEL_TO_POINT_RATIO * 5 'Right
        eDimensions(2) = dPoint.Top - PIXEL_TO_POINT_RATIO * 5  'Top
        eDimensions(3) = dPoint.Top + PIXEL_TO_POINT_RATIO * 5  'Bottom
    End If
    If dPoint Is Nothing And dLabel Is Nothing Then
        'Get chart dimensions
        eDimensions(0) = dChart.PlotArea.Left + PIXEL_TO_POINT_RATIO * 22                         'Left
        eDimensions(1) = dChart.PlotArea.Left + dChart.PlotArea.Width - PIXEL_TO_POINT_RATIO * 22 'Right
        eDimensions(2) = dChart.PlotArea.Top - PIXEL_TO_POINT_RATIO * 4                           'Top
        eDimensions(3) = dChart.PlotArea.Top + dChart.PlotArea.Height - PIXEL_TO_POINT_RATIO * 4  'Bottom
    End If

    getElementDimensions = eDimensions 'Return dimensions array in Points
End Function

Function detectOverlap(ByVal dLabel1 As DataLabel, Optional ByVal dLabel2 As DataLabel, Optional ByVal dPoint As Point, Optional ByVal dChart As Chart) As Boolean
    'Left, Right, Top, Bottom
    Dim AxL, AxR, AyT, AyB As Double 'First label coordinates
    Dim BxL, BxR, ByT, ByB As Double 'Second label coordinates
    Dim eDimensions() As Double 'Element dimensions

    eDimensions = getElementDimensions(dLabel1)
    AxL = eDimensions(0)
    AxR = eDimensions(1)
    AyT = eDimensions(2)
    AyB = eDimensions(3)

    If dPoint Is Nothing And dChart Is Nothing Then
        'Compare with another label
        eDimensions = getElementDimensions(dLabel2)
    End If
    If dLabel2 Is Nothing And dChart Is Nothing Then
        'Compare with a point
        eDimensions = getElementDimensions(, dPoint)
    End If
    If dPoint Is Nothing And dLabel2 Is Nothing Then
        'Compare with chart area
        eDimensions = getElementDimensions(, , dChart)
    End If
    BxL = eDimensions(0)
    BxR = eDimensions(1)
    ByT = eDimensions(2)
    ByB = eDimensions(3)

    If dChart Is Nothing Then
        detectOverlap = (AxL <= BxR And AxR >= BxL And AyT <= ByB And AyB >= ByT) 'Reverse De Morgan's Law
    Else
        detectOverlap = Not (AxL >= BxL And AxR <= BxR And AyT >= ByT And AyB <= ByB) 'Is in chart bounds (working in IV quadrant)
    End If
End Function

我意识到代码有点粗糙而且没有优化，但我不能在这个项目上花更多的时间。如果有人选择继续这个项目，我已经留下了很多笔记来帮助阅读它。

希望这会有所帮助。祝愿，Schadenfreude。

Answer 2

在你的功能基础上，我做了一个例程，随机地重新定位标签，根据它会引起多少重叠来分配分数，从而进行优化。结果对于我自己的数据集来说并不是很好，但我认为它可以在大多数用法中轻松调整。

边框和轴标签存在一些问题，我稍后可能会对此进行说明。

Option Explicit

Sub ExampleUsage()

    RearrangeScatterLabels ActiveSheet.ChartObjects(1).Chart, 3

End Sub

Sub RearrangeScatterLabels(plot As Chart, Optional timelimit As Double = 5)

    Dim sCollection As SeriesCollection
    Set sCollection = plot.SeriesCollection

    Dim pCount As Integer
    pCount = sCollection(1).Points.Count
    If pCount < 2 Then Exit Sub

    Dim dPoints() As Point

    Dim xArr() As Double ' Label center position X
    Dim yArr() As Double ' Label center position Y
    Dim wArr() As Double ' Label width
    Dim hArr() As Double ' Label height
    Dim pArr() As Double ' Marker position X
    Dim qArr() As Double ' Marker position Y
    Dim mArr() As Double ' Markersize

    ReDim dPoints(1 To pCount)

    ReDim xArr(1 To pCount)
    ReDim yArr(1 To pCount)
    ReDim wArr(1 To pCount)
    ReDim hArr(1 To pCount)
    ReDim pArr(1 To pCount)
    ReDim qArr(1 To pCount)
    ReDim mArr(1 To pCount)

    Dim theta As Double

    Dim i As Integer
    Dim j As Integer
    Dim dblStart As Double

    ' Loop through all points to get their handles and coordinates
    For i = 1 To pCount

        ' Store all point objects
        Set dPoints(i) = sCollection(1).Points(i)

        ' Extract their coordinates and size
        pArr(i) = dPoints(i).Left
        qArr(i) = dPoints(i).Top
        mArr(i) = dPoints(i).MarkerSize

        ' Store the size of the corresponding labels
        wArr(i) = dPoints(i).DataLabel.Width
        hArr(i) = dPoints(i).DataLabel.Height

        ' Starting position (center of label) is middle below
        xArr(i) = pArr(i)
        yArr(i) = qArr(i) + mArr(i)

    Next

    Dim newX As Double
    Dim newY As Double
    Dim dE As Double

    Dim wgtOverlap As Double
    Dim wgtDistance As Double
    Dim wgtClose As Double

    wgtOverlap = 10000 ' Extra penalty for overlapping
    wgtDistance = 10000 ' Penalty for being nearby other labels
    wgtClose = 10 ' Penalty for being further from marker

    ' Limit the function by time
    dblStart = Timer
    Do Until TimerDiff(dblStart, Timer) > timelimit

        ' Pick a random label to move around
        i = Int(Rnd * pCount + 1)

        ' Pick a new random position by angle
        theta = Rnd * 2 * Application.WorksheetFunction.Pi()

        ' Determine the position it would shift to
        If Abs(Sin(theta) * wArr(i)) > Abs(hArr(i) * Cos(theta)) Then
            ' above or below
            If Sin(theta) > 0 Then
                ' above
                newX = pArr(i) + wArr(i) * Cos(theta) / 2
                newY = qArr(i) - hArr(i) / 2 - mArr(i) / 2
            Else
                ' below
                newX = pArr(i) + wArr(i) * Cos(theta) / 2
                newY = qArr(i) + hArr(i) / 2 + mArr(i) / 2
            End If
        Else
            ' left or right side
            If Cos(theta) < 0 Then
                ' left
                newX = pArr(i) - wArr(i) / 2 - mArr(i) / 2
                newY = qArr(i) - hArr(i) * Sin(theta) / 2
            Else
                ' right
                newX = pArr(i) + wArr(i) / 2 + mArr(i) / 2
                newY = qArr(i) - hArr(i) * Sin(theta) / 2
            End If
        End If

        ' Determine increase in energy caused by this shift
        dE = 0
        For j = 1 To pCount
            If i <> j Then
                ' Current overlap with labels
                If 2 * Abs(xArr(i) - xArr(j)) < wArr(i) + wArr(j) _
                    And 2 * Abs(yArr(i) - yArr(j)) < hArr(i) + hArr(j) Then
                    dE = dE - Abs(xArr(i) - xArr(j) + (wArr(i) + wArr(j)) / 2) _
                        * Abs(yArr(i) - yArr(j) + (hArr(i) + hArr(j)) / 2)
                    dE = dE - wgtOverlap
                End If
                ' New overlap with labels
                If 2 * Abs(newX - xArr(j)) < wArr(i) + wArr(j) _
                    And 2 * Abs(newY - yArr(j)) < hArr(i) + hArr(j) Then
                    dE = dE + Abs(newX - xArr(j) + (wArr(i) + wArr(j)) / 2) _
                        * Abs(newY - yArr(j) + (hArr(i) + hArr(j)) / 2)
                    dE = dE + wgtOverlap
                End If
                ' Current overlap with labels
                If Abs(xArr(i) - pArr(j)) < wArr(i) / 2 + mArr(j) _
                    And Abs(yArr(i) - qArr(j)) < hArr(i) / 2 + mArr(j) Then
                    dE = dE - wgtOverlap
                End If
                ' New overlap with points
                If Abs(newX - pArr(j)) < wArr(i) / 2 + mArr(j) _
                    And Abs(newY - qArr(j)) < hArr(i) / 2 + mArr(j) Then
                    dE = dE + wgtOverlap
                End If
                ' We like the neighbours to be far away
                dE = dE - wgtDistance / ((xArr(i) - xArr(j)) ^ 2 + (yArr(i) - yArr(j)) ^ 2)
                dE = dE + wgtDistance / ((newX - xArr(j)) ^ 2 + (newY - yArr(j)) ^ 2)
            End If
            ' We like the offsets to be low
            dE = dE - wgtClose * (Abs(xArr(i) - pArr(i)) + Abs(yArr(i) - qArr(i)))
            dE = dE + wgtClose * (Abs(newX - pArr(i)) + Abs(newY - qArr(i)))
        Next

        ' If it didn't get worse, adjust to new position
        If dE <= 0 Then
            xArr(i) = newX
            yArr(i) = newY
        End If

    Loop

    ' Actually adjust the labels
    For i = 1 To pCount
        dPoints(i).DataLabel.Left = xArr(i) - wArr(i) / 2
        dPoints(i).DataLabel.Top = yArr(i) - hArr(i) / 2
    Next

End Sub

' Timer function from Peter Albert
' http://stackoverflow.com/questions/15634623
Function TimerDiff(dblTimerStart As Double, dblTimerEnd As Double)
    Dim dblTemp As Double
    dblTemp = dblTimerEnd - dblTimerStart
    If dblTemp < -43200 Then
        dblTemp = dblTemp + 86400
    End If
    TimerDiff = dblTemp
End Function

Excel XY图表（散点图）数据标签无重叠

2 个答案: