英文:
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
英文:
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("Sheet3") ' Replace "Sheet3" with your actual sheet name
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
' Create a new column for the BrandSize values (if not already created)
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
' Create a new column for the Size Numerical values (if not already created)
If ws.Cells(1, 6).value <> "Size Numerical" Then
SortDataAndAssignSizeNumerical
End If
' Calculate minimum value for the axis scale
Dim minValue As Double
minValue = Application.WorksheetFunction.Min(ws.Range("F2:F" & lastRow))
' Create scatter plot
Set chart = chartSheet.ChartObjects.Add(0, 0, chartSheet.Cells(1, 1).width, chartSheet.Cells(1, 1).height)
'Set chart = ws.ChartObjects.Add(100, 100, 600, 300)
chart.chart.ChartType = xlXYScatter
chart.chart.HasTitle = True
chart.chart.ChartTitle.Text = "Price / Value Benchmark"
' Set axis labels
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"
' Remove gridlines
chart.chart.Axes(xlCategory).MajorGridlines.Delete
chart.chart.Axes(xlValue).MajorGridlines.Delete
' Set minimum scale for category (Size Numerical) axis
'chart.chart.Axes(xlCategory).MinimumScale = minValue
chart.chart.Axes(xlCategory).MinimumScale = 0
' Set Major Unit for Value (Price) Axis
chart.chart.Axes(xlValue).MajorUnit = 5 ' Adjust this value as needed
chart.chart.Axes(xlCategory).MajorUnit = 2
' Set chart size
'chart.width = 600
'chart.height = 300
chart.Left = 0
chart.Top = 0
chart.width = 14.17 * 72
chart.height = 8.78 * 72
'chart.width = Application.width
'chart.height = Application.height
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
' Add scatter series data
Set scatterSeries = chart.chart.SeriesCollection.NewSeries
scatterSeries.Name = "Scatter Data"
scatterSeries.Values = ws.Range("D2:D" & lastRow) ' Price column
scatterSeries.xValues = ws.Range("F2:F" & lastRow) ' Size Numerical column
' 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
'scatterSeries.LeaderLines.Border.colorIndex = 5
Dim pointsCount As Long
pointsCount = scatterSeries.Points.Count
'scatterSeries.Points(i).HasLeaderLines = True
For i = 1 To pointsCount
Set Point = scatterSeries.Points(i)
' Adjust the data label position by 1 pixel to the right
labelLeft = Point.DataLabel.Top + 8
Point.DataLabel.Top = labelLeft
' Add a leader line
scatterSeries.ApplyDataLabels
Point.ApplyDataLabels
'scatterSeries.Points(i).HasLeaderLines = True
scatterSeries.Points(i).MarkerStyle = xlMarkerStyleCircle
scatterSeries.Points(i).DataLabel.Text = ws.Cells(i + 1, 2).value ' 'Deal' column
scatterSeries.Points(i).DataLabel.Font.size = 5
scatterSeries.Points(i).MarkerSize = 5 ' 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
' Set point color based on the brand
scatterSeries.Points(i).Format.Fill.ForeColor.RGB = brandColors(ws.Cells(i + 1, 1).value)
Next i
' Hide major tick marks on the x-axis
chart.chart.Axes(xlCategory).TickLabelPosition = xlTickLabelPositionNone
chart.chart.Axes(xlValue).TickLabels.Font.size = 4 ' Adjust the font size as needed
chart.chart.HasLegend = False
' Activate the PriceBenchmark sheet
chartSheet.Activate
' 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
答案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
示例数据和图表
可以将以下逻辑集成进去。如果不正确,请确认“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.
' Create scatter line chart
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
' 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) <> Cells(i - 1, 1) Then
cht.FullSeriesCollection(1).Points(i - 1).Format.Line.Visible = msoFalse
End If
Next
End Sub
Sample data and chart
The logic could be integrated like below. If it is not correct, Please confirm what's in Size Numerical
column?
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
答案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 > 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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论