在Excel VBA散点图中断连续线

huangapple go评论67阅读模式
英文:

Break Continuous Line in Excel VBA Scatter Plot

问题

我有一个在VBA中创建的散点图,并设置了系列的线条,它的效果非常好,只是线条是从点到点连续的,而不是在每个点的末端停止。换句话说,理想的解决方案是每个系列的“点”之间有一条垂直线。

这是创建图表的VBA代码:

Sub CreateScatterPlotWithUniqueBrandColors()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim chart As ChartObject
    Dim chartSheet As Worksheet
    Dim scatterSeries As series
    Dim i As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet3") ' 将"Sheet3"替换为实际的工作表名称
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    On Error Resume Next
    Set chartSheet = ThisWorkbook.Sheets("PriceBenchmark")
    On Error GoTo 0
    
    If chartSheet Is Nothing Then
        Set chartSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        chartSheet.Name = "PriceBenchmark"
    End If
    
    ' 如果还没有创建BrandSize值的新列,则创建BrandSize值的新列
    If ws.Cells(1, 5).Value <> "BrandSize" Then
        ws.Cells(1, 5).Value = "BrandSize"
        For i = 2 To lastRow
            ws.Cells(i, 5).Value = ws.Cells(i, 1).Value & "-" & ws.Cells(i, 3).Value
        Next i
    End If
    
    ' 如果还没有创建Size Numerical值的新列,则创建Size Numerical值的新列
    If ws.Cells(1, 6).Value <> "Size Numerical" Then
        SortDataAndAssignSizeNumerical
    End If
    
    ' 计算轴刻度的最小值
    Dim minValue As Double
    minValue = Application.WorksheetFunction.Min(ws.Range("F2:F" & lastRow))
    
    ' 创建散点图
    Set chart = chartSheet.ChartObjects.Add(0, 0, chartSheet.Cells(1, 1).Width, chartSheet.Cells(1, 1).Height)
    chart.Chart.ChartType = xlXYScatter
    chart.Chart.HasTitle = True
    chart.Chart.ChartTitle.Text = "Price / Value Benchmark"
    
    ' 设置轴标签
    chart.Chart.Axes(xlCategory).HasTitle = True
    chart.Chart.Axes(xlCategory).AxisTitle.Text = "Size:Brand"
    chart.Chart.Axes(xlValue).HasTitle = True
    chart.Chart.Axes(xlValue).AxisTitle.Text = "Price"
    
    ' 移除网格线
    chart.Chart.Axes(xlCategory).MajorGridlines.Delete
    chart.Chart.Axes(xlValue).MajorGridlines.Delete
    
    ' 设置类别(Size Numerical)轴的最小刻度
    chart.Chart.Axes(xlCategory).MinimumScale = 0
    
    ' 设置值(Price)轴的主要单位
    chart.Chart.Axes(xlValue).MajorUnit = 5 ' 根据需要调整此值
    chart.Chart.Axes(xlCategory).MajorUnit = 2
    
    ' 设置图表大小
    chart.Left = 0
    chart.Top = 0
    chart.Width = 14.17 * 72
    chart.Height = 8.78 * 72
    
    ' 创建品牌颜色的字典
    Dim brandColors As Object
    Set brandColors = CreateObject("Scripting.Dictionary")
    
    ' 创建唯一品牌的字典
    Dim uniqueBrands As Object
    Set uniqueBrands = CreateObject("Scripting.Dictionary")
    
    For i = 2 To lastRow
        Dim brand As String
        brand = ws.Cells(i, 1).Value
        
        If Not brandColors.Exists(brand) Then
            brandColors(brand) = GetRandomRGBColor()
        End If
        
        If Not uniqueBrands.Exists(brand) Then
            uniqueBrands.Add brand, brand
        End If
    Next i
    
    ' 添加散点系列数据
    Set scatterSeries = chart.Chart.SeriesCollection.NewSeries
    scatterSeries.Name = "Scatter Data"
    scatterSeries.Values = ws.Range("D2:D" & lastRow) ' Price列
    scatterSeries.xValues = ws.Range("F2:F" & lastRow) ' Size Numerical列
    
    ' 为每个点添加数据标签
    scatterSeries.HasDataLabels = True
    scatterSeries.HasLeaderLines = True
    scatterSeries.DataLabels.Position = xlLabelPositionRight
    scatterSeries.LeaderLines.Border.Color = RGB(192, 192, 192)
    scatterSeries.LeaderLines.Format.Line.DashStyle = msoLineSysDash
    scatterSeries.LeaderLines.Format.Line.Weight = 0.8
    
    Dim pointsCount As Long
    pointsCount = scatterSeries.Points.Count
    
    For i = 1 To pointsCount
        Set Point = scatterSeries.Points(i)
        
        ' 将数据标签位置向右调整1个像素
        labelLeft = Point.DataLabel.Top + 8
        Point.DataLabel.Top = labelLeft
        
        ' 添加连接线
        scatterSeries.ApplyDataLabels
        Point.ApplyDataLabels
        
        scatterSeries.Points(i).MarkerStyle = xlMarkerStyleCircle
        scatterSeries.Points(i).DataLabel.Text = ws.Cells(i + 1, 2).Value ' Deal列
        scatterSeries.Points(i).DataLabel.Font.Size = 5
        scatterSeries.Points(i).MarkerSize = 5 ' 根据需要调整此值
        scatterSeries.Points(i).Format.Line.Visible = msoTrue
        scatterSeries.Points(i).Format.Line.ForeColor.RGB = RGB(192, 192, 192)
        scatterSeries.Points(i).Format.Line.DashStyle = msoLineSysDash
        scatterSeries.Points(i).Format.Line.Weight = 0.8
        
        ' 根据品牌设置点的颜色
        scatterSeries.Points(i).Format.Fill.ForeColor.RGB = brandColors(ws.Cells(i + 1, 1).Value)
    Next i
    
    ' 隐藏x轴上的主要刻度线
    chart.Chart.Axes(xlCategory).TickLabelPosition = xlTickLabelPositionNone
    chart.Chart.Axes(xlValue).TickLabels.Font.Size = 4 ' 根据需要调整字体大小
    chart.Chart.HasLegend = False
    
    ' 激活PriceBenchmark工作表
    chartSheet.Activate
    
    ' 设置图表工作表的缩放
    ActiveWindow.Zoom = 120

End Sub

在上述代码中设置线条的部分,我需要一种方法来中断线条或类似的方式,以便它不会继续跨越x轴到下一个点,如下所示:

scatterSeries.Points(i).Format.Line.Visible = msoTrue
scatterSeries.Points(i).Format.Line.ForeColor.RGB = RGB(192, 192, 192)
scatterSeries.Points(i).Format.Line.DashStyle = msoLineSysDash
scatterSeries.Points(i).Format.Line.Weight = 0.8

这是示例数据:
在Excel VBA散点图中断连续线

在Excel VBA散点图中断连续线

英文:

I have a scatter plot that I am creating in VBA and have set the Line for the series which is working perfectly except for the line is continuous from point-to-point, rather than stop at the end of each point. In other words, the ideal solution would result in a single vertical line for each Series 'Point' of values.

Here is my vba code for the procedure that creates the chart:

Sub CreateScatterPlotWithUniqueBrandColors()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim chart As ChartObject
    Dim chartSheet As Worksheet
    Dim scatterSeries As series
    Dim i As Long
    
    Set ws = ThisWorkbook.Worksheets(&quot;Sheet3&quot;) &#39; Replace &quot;Sheet3&quot; with your actual sheet name
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    On Error Resume Next
    Set chartSheet = ThisWorkbook.Sheets(&quot;PriceBenchmark&quot;)
    On Error GoTo 0
    
    If chartSheet Is Nothing Then
        Set chartSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        chartSheet.Name = &quot;PriceBenchmark&quot;
    End If
    
    &#39; Create a new column for the BrandSize values (if not already created)
    If ws.Cells(1, 5).value &lt;&gt; &quot;BrandSize&quot; Then
        ws.Cells(1, 5).value = &quot;BrandSize&quot;
        For i = 2 To lastRow
            ws.Cells(i, 5).value = ws.Cells(i, 1).value &amp; &quot;-&quot; &amp; ws.Cells(i, 3).value
        Next i
    End If
    
    &#39; Create a new column for the Size Numerical values (if not already created)
    If ws.Cells(1, 6).value &lt;&gt; &quot;Size Numerical&quot; Then
        SortDataAndAssignSizeNumerical
    End If
    
    &#39; Calculate minimum value for the axis scale
    Dim minValue As Double
    minValue = Application.WorksheetFunction.Min(ws.Range(&quot;F2:F&quot; &amp; lastRow))
    
    &#39; Create scatter plot
    Set chart = chartSheet.ChartObjects.Add(0, 0, chartSheet.Cells(1, 1).width, chartSheet.Cells(1, 1).height)
    &#39;Set chart = ws.ChartObjects.Add(100, 100, 600, 300)
    chart.chart.ChartType = xlXYScatter
    chart.chart.HasTitle = True
    chart.chart.ChartTitle.Text = &quot;Price / Value Benchmark&quot;
    
    &#39; Set axis labels
    chart.chart.Axes(xlCategory).HasTitle = True
    chart.chart.Axes(xlCategory).AxisTitle.Text = &quot;Size:Brand&quot;
    chart.chart.Axes(xlValue).HasTitle = True
    chart.chart.Axes(xlValue).AxisTitle.Text = &quot;Price&quot;
    
    &#39; Remove gridlines
    chart.chart.Axes(xlCategory).MajorGridlines.Delete
    chart.chart.Axes(xlValue).MajorGridlines.Delete
    
    &#39; Set minimum scale for category (Size Numerical) axis
    &#39;chart.chart.Axes(xlCategory).MinimumScale = minValue
    chart.chart.Axes(xlCategory).MinimumScale = 0
    
    &#39; Set Major Unit for Value (Price) Axis
    chart.chart.Axes(xlValue).MajorUnit = 5 &#39; Adjust this value as needed
    chart.chart.Axes(xlCategory).MajorUnit = 2
    
    &#39; Set chart size
    &#39;chart.width = 600
    &#39;chart.height = 300
    chart.Left = 0
    chart.Top = 0
    chart.width = 14.17 * 72
    chart.height = 8.78 * 72
    &#39;chart.width = Application.width
    &#39;chart.height = Application.height


    Dim brandColors As Object
    Set brandColors = CreateObject(&quot;Scripting.Dictionary&quot;)
    
    Dim uniqueBrands As Object
    Set uniqueBrands = CreateObject(&quot;Scripting.Dictionary&quot;)
    
    For i = 2 To lastRow
        Dim brand As String
        brand = ws.Cells(i, 1).value
        
        If Not brandColors.Exists(brand) Then
            brandColors(brand) = GetRandomRGBColor()
        End If
        
        If Not uniqueBrands.Exists(brand) Then
            uniqueBrands.Add brand, brand
        End If
    Next i
    
    &#39; Add scatter series data
    Set scatterSeries = chart.chart.SeriesCollection.NewSeries
    scatterSeries.Name = &quot;Scatter Data&quot;
    scatterSeries.Values = ws.Range(&quot;D2:D&quot; &amp; lastRow) &#39; Price column
    scatterSeries.xValues = ws.Range(&quot;F2:F&quot; &amp; lastRow) &#39; Size Numerical column
    
    &#39; Add data labels for each point
    scatterSeries.HasDataLabels = True
    scatterSeries.HasLeaderLines = True
    scatterSeries.DataLabels.Position = xlLabelPositionRight
    scatterSeries.LeaderLines.Border.Color = RGB(192, 192, 192)
    scatterSeries.LeaderLines.Format.Line.DashStyle = msoLineSysDash
    scatterSeries.LeaderLines.Format.Line.Weight = 0.8
    &#39;scatterSeries.LeaderLines.Border.colorIndex = 5
    Dim pointsCount As Long
    pointsCount = scatterSeries.Points.Count
    &#39;scatterSeries.Points(i).HasLeaderLines = True
    For i = 1 To pointsCount
    
        Set Point = scatterSeries.Points(i)
        
        &#39; Adjust the data label position by 1 pixel to the right
        labelLeft = Point.DataLabel.Top + 8
        Point.DataLabel.Top = labelLeft
        
        &#39; Add a leader line
        scatterSeries.ApplyDataLabels
        Point.ApplyDataLabels
        
        &#39;scatterSeries.Points(i).HasLeaderLines = True
        scatterSeries.Points(i).MarkerStyle = xlMarkerStyleCircle
        scatterSeries.Points(i).DataLabel.Text = ws.Cells(i + 1, 2).value &#39; &#39;Deal&#39; column
        scatterSeries.Points(i).DataLabel.Font.size = 5
        scatterSeries.Points(i).MarkerSize = 5 &#39; Adjust this value as needed
        scatterSeries.Points(i).Format.Line.Visible = msoTrue
        scatterSeries.Points(i).Format.Line.ForeColor.RGB = RGB(192, 192, 192)
        scatterSeries.Points(i).Format.Line.DashStyle = msoLineSysDash
        scatterSeries.Points(i).Format.Line.Weight = 0.8
        &#39; Set point color based on the brand
        scatterSeries.Points(i).Format.Fill.ForeColor.RGB = brandColors(ws.Cells(i + 1, 1).value)
    Next i
    
    &#39; Hide major tick marks on the x-axis
    chart.chart.Axes(xlCategory).TickLabelPosition = xlTickLabelPositionNone
    chart.chart.Axes(xlValue).TickLabels.Font.size = 4 &#39; Adjust the font size as needed
    chart.chart.HasLegend = False

    &#39; Activate the PriceBenchmark sheet
    chartSheet.Activate
    
    &#39; Set the Zoom on the Chart Sheet
    ActiveWindow.Zoom = 120


End Sub

In this code below where the line is set, i need a way to break the line or something of the sort so that it does not continue to the next point across the x-axis as shown in the image:

scatterSeries.Points(i).Format.Line.Visible = msoTrue
        scatterSeries.Points(i).Format.Line.ForeColor.RGB = RGB(192, 192, 192)
        scatterSeries.Points(i).Format.Line.DashStyle = msoLineSysDash
        scatterSeries.Points(i).Format.Line.Weight = 0.8

Here is the sample data:
在Excel VBA散点图中断连续线

在Excel VBA散点图中断连续线

答案1

得分: 1

没有问题,我会为你翻译这段内容。以下是翻译的结果:

很难在没有你的示例数据的情况下创建图表。我提供的代码演示了如何从现有图表中删除非垂直网格线。

' 创建散点线图
Sub CreateChart()
    ActiveSheet.Shapes.AddChart2(240, xlXYScatterLines).Select
    ActiveChart.SetSourceData Source:=Range("Sheet1!$A$1:$B$9")
    Selection.Top = [d2].Top
    Selection.Left = [d2].Left
End Sub

' 删除非垂直线
Sub RemoveLine()
    Dim cht As Chart
    Dim LstRow As Integer
    Set cht = Sheet1.Shapes(1).Chart
    LstRow = [a1].End(xlDown).Row
    For i = 3 To LstRow
        If Cells(i, 1) <> Cells(i - 1, 1) Then
            cht.FullSeriesCollection(1).Points(i - 1).Format.Line.Visible = msoFalse
        End If
    Next
End Sub

示例数据和图表

在Excel VBA散点图中断连续线


可以将以下逻辑集成进去。如果不正确,请确认“Size Numerical”列中的内容是什么?

    If i > 1 Then
        If ws.Cells(i + 1, "F").Value = ws.Cells(i, "F").Value Then
            scatterSeries.Points(i).Format.Line.Visible = msoTrue
            scatterSeries.Points(i).Format.Line.ForeColor.RGB = RGB(192, 192, 192)
            scatterSeries.Points(i).Format.Line.DashStyle = msoLineSysDash
            scatterSeries.Points(i).Format.Line.Weight = 0
        Else
            scatterSeries.Points(i).Format.Line.Visible = msoFalse
        End If
    End If
英文:

It is difficult to create the chart without any your sample data. The code I provided demonstrates how to remove the non-vertical gridlines from an existing chart.

&#39; Create scatter line chart
Sub CreateChart()
    ActiveSheet.Shapes.AddChart2(240, xlXYScatterLines).Select
    ActiveChart.SetSourceData Source:=Range(&quot;Sheet1!$A$1:$B$9&quot;)
    Selection.Top = [d2].Top
    Selection.Left = [d2].Left
End Sub

&#39; Remove non-vertical lines
Sub RemoveLine()
    Dim cht As chart
    Dim LstRow As Integer
    Set cht = Sheet1.Shapes(1).chart
    LstRow = [a1].End(xlDown).Row
    For i = 3 To LstRow
        If Cells(i, 1) &lt;&gt; Cells(i - 1, 1) Then
            cht.FullSeriesCollection(1).Points(i - 1).Format.Line.Visible = msoFalse
        End If
    Next
End Sub

Sample data and chart

在Excel VBA散点图中断连续线


The logic could be integrated like below. If it is not correct, Please confirm what's in Size Numerical column?

    If i &gt; 1 Then
        If ws.Cells(i + 1, &quot;F&quot;).value = ws.Cells(i, &quot;F&quot;).value Then
            scatterSeries.Points(i).Format.Line.Visible = msoTrue
            scatterSeries.Points(i).Format.Line.ForeColor.RGB = RGB(192, 192, 192)
            scatterSeries.Points(i).Format.Line.DashStyle = msoLineSysDash
            scatterSeries.Points(i).Format.Line.Weight = 0
        Else
            scatterSeries.Points(i).Format.Line.Visible = msoFalse
        End If
    End If

答案2

得分: 1

稍微不同的方法是从图表数据中运行:

Sub Tester()
    RemoveConnectors ActiveSheet.ChartObjects(1).Chart
End Sub


Sub RemoveConnectors(cht As Chart)
    Dim i As Long, xVals
    With cht.SeriesCollection(1)
        xVals = .XValues
        For i = 1 To UBound(xVals)
            If i > 1 Then
                If xVals(i) <> xVals(i - 1) Then
                    .Points(i).Format.Line.Visible = msoFalse
                End If
            End If
        Next i
    End With
End Sub
英文:

Slightly different approach running from just the chart data:

Sub Tester()
    RemoveConnectors ActiveSheet.ChartObjects(1).Chart
End Sub


Sub RemoveConnectors(cht As Chart)
    Dim i As Long, xVals
    With cht.SeriesCollection(1)
        xVals = .XValues
        For i = 1 To UBound(xVals)
            If i &gt; 1 Then
                If xVals(i) &lt;&gt; xVals(i - 1) Then
                    .Points(i).Format.Line.Visible = msoFalse
                End If
            End If
        Next i
    End With
End Sub

huangapple
  • 本文由 发表于 2023年8月9日 03:00:07
  • 转载请务必保留本文链接:https://go.coder-hub.com/76862493.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定