web-dev-qa-db-ja.com

折れ線グラフで重複するデータラベルを修正するExcelマクロ

1つまたは複数のシリーズコレクションを含む折れ線グラフのデータラベルの位置を固定して、互いに重ならないようにするマクロを検索/作成しようとしています。

私は自分のマクロのいくつかの方法を考えていましたが、それを作ろうとすると、これは私には難しすぎて頭痛がすることを理解しています。

見逃したことはありますか？そのようなマクロについて知っていますか？

データラベルが重複しているグラフの例を次に示します。

enter image description here

データラベルを手動で修正したグラフの例を次に示します。

enter image description here

excelexcel-vbachartsexcel-2007vba
8
Ron

このタスクは基本的に2つのステップに分けられます：accessChartオブジェクトを取得してLabelsを取得し、manipulateラベルの位置をオーバーラップを回避します。

与えられたサンプルでは、​​すべての系列が共通のX軸にプロットされ、ラベルがこの次元で重ならないようにX値が十分に分散されています。したがって、提供されるソリューションは、各Xポイントのラベルのグループのみを順番に扱います。

ラベルへのアクセス

このSubはグラフを解析し、XポイントごとにLabelsの配列を順番に作成します

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についての注意

このアプローチを機能させるには、DataLabel.WidthプロパティとDataLabel.Heightプロパティを持つバージョンのExcelが必要です。バージョン2003SP2（およびおそらくそれ以前）はそうではありません。

18
chris neilsen

このマクロは、データソースが2つの隣接する列にリストされている場合に、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
Danny Speranza