最近，本人连续发布了三篇关于制作福彩双色球动态幻圆图的VBA+Excel的方法及其程序的系列文章，收到广大友友的喜爱，我也备受鼓舞，继续为友友提供相关的内容，反馈友友。
关注我，进入我的主页，你可以看到更多内容。
福彩双色球篮球折线图制作的VBA+Excel的方法及其程序的内容如下。
一、新建一个Excel工作簿。
1、按照我已发布的《福彩双色球幻圆图的VBA程序（第三部分）》给出的方法，新建一个表，并将其重命名为“Data"，下载双色球历年数据。
2、增加一个表，将其重命名为”篮球折线图“。
3、在”篮球折线图“这表上添加两个”滚动条“控件ScrollBar1和ScrollBar2，并按下图放置到相应的位置。
4、设置ScrollBar1”滚动条“控件属性。
5、设置ScrollBar2”滚动条“控件属性.
二、写入相关代码
1、点击”开发工具“”宏“，填写宏名”批量生成折线和篮球“，点击”创建“，在宏程序中粘贴代码。
Sheets("篮球折线图").Select
'设置表头
[A1] = "期号"
[B1] = "篮球号"
'设置列宽
Columns("A:A").Select
Selection.ColumnWidth = 10.25
Columns("B:B").Select
Selection.ColumnWidth = 5.75
Columns("C:R").Select
Selection.ColumnWidth = 2.38
'设置行高
Rows("1:1").Select
Selection.RowHeight = 18.75
Rows("2:22").Select
Selection.RowHeight = 14.25
'批量生成折线
For i = 1 To 19
If Cells(i + 1, 2).Value > Cells(i + 2, 2).Value Then
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, (i - 1) * 14.25 + 27 + 14.25 / 2, 150, (i - 1) * 14.25 + 27 + 14.25 / 2).Select
Selection.Name = "Line" & i
Application.CommandBars("Format Object").Visible = False
'设置形状边框颜色——黑色
With Selection.ShapeRange.line
.Visible = msoTrue
.Weight = 0.75
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
End With
End If
If Cells(i + 1, 2).Value < Cells(i + 2, 2).Value Then
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, (i - 1) * 14.25 + 27 + 14.25 / 2, 150, (i - 1) * 14.25 + 27 + 14.25 / 2).Select
Selection.Name = "Line" & i
Application.CommandBars("Format Object").Visible = False
'设置形状边框颜色——黑色
With Selection.ShapeRange.line
.Visible = msoTrue
.Weight = 0.75
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
End With
End If
If Cells(i + 1, 2).Value = Cells(i + 2, 2).Value Then
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, (i - 1) * 14.25 + 27 + 14.25 / 2, 150, (i - 1) * 14.25 + 27 + 14.25 / 2).Select
Selection.Name = "Line" & i
Application.CommandBars("Format Object").Visible = False
'设置形状边框颜色——黑色
With Selection.ShapeRange.line
.Visible = msoTrue
.Weight = 0.75
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
End With
End If
Next
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 130, 18, 130, 300).Select
Selection.Name = "Line" & i
Application.CommandBars("Format Object").Visible = False
'设置形状边框颜色——黑色
With Selection.ShapeRange.line
.Visible = msoTrue
.Weight = 1.5
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
'批量生成篮球1
For i = 1 To 20
'在活动工作表上添加新的形状—msoShapeOval(圆形)
ActiveSheet.Shapes.AddShape(msoShapeOval, 140, 20 + (i - 1) * 14.26, 12, 12).Select
Selection.Placement = xlFreeFloating
Application.CommandBars("Format Object").Visible = False
'将形状重命名为"blueball" & i
Selection.Name = "blueball" & i
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = i
'设置形状边框颜色——黑色
With Selection.ShapeRange.line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
End With
'填充形状颜色——白色
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.WordWrap = msoFalse
With Selection.ShapeRange.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
End With
Application.CommandBars("Format Object").Visible = False
Next
'批量生成篮球2
For i = 1 To 16
'在活动工作表上添加新的形状—msoShapeOval(圆形)
ActiveSheet.Shapes.AddShape(msoShapeOval, 89 + i * 18, 3, 12, 12).Select
Selection.Placement = xlFreeFloating
Application.CommandBars("Format Object").Visible = False
'将形状重命名为"blueball" & i
Selection.Name = "blueball" & i + 16
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = i
'设置形状边框颜色——黑色
With Selection.ShapeRange.line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
End With
'填充形状颜色——白色
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.WordWrap = msoFalse
With Selection.ShapeRange.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
End With
Application.CommandBars("Format Object").Visible = False
Next
2，再创建一个宏，并命名为”删除所有形状“。这个运行这个宏的目的，是用户在实际运行过程中无意删除了部分折线或篮球形状（Shapes）后，点击运行这个宏，则可以恢复所有的折线和篮球形状（Shapes）。代码如下。
Dim shp As Shape
Sheets("篮球折线图").Select
For Each shp In ActiveSheet.Shapes
If shp.Type = msoConnectorStraight Then
shp.Delete
End If
Next shp
End Sub3、向名为ScrollBar1的”滚动条“控件的Change事件粘贴代码。代码如下。
Private Sub ScrollBar1_Change()
Dim i As Integer
Dim j As Integer
'清除选定区域的数据
Range("C2:R23").Select
Selection.ClearContents
Sheets("Data").Select
'统计期数 彩票期数(Number of Lottery Periods)NoLP
Nolp = ActiveSheet.UsedRange.Rows.Count - 2
Sheets("篮球折线图").Select
ScrollBar1.Max = Nolp
ScrollBar1.Min = 3
For i = 1 To 20
Sheets("篮球折线图").Cells(i + 1, 1).Value = Sheets("Data").Cells((ScrollBar1.Value - 21) + i + 2, 1).Value & "期"
Sheets("篮球折线图").Cells(i + 1, 2).Value = Sheets("Data").Cells((ScrollBar1.Value - 21) + i + 2, 9).Value
Next
Dim shp As Shape
For i = 1 To 19
Set shp = ActiveSheet.Shapes("Line" & i)
shp.height = 0
shp.Rotation = 0
Next
For i = 1 To 19
Set shp = ActiveSheet.Shapes("Line" & i)
If Cells(i + 1, 2).Value > Cells(i + 2, 2).Value Then
shp.left = 104 + (Cells(i + 2, 2).Value - 1) * 18 + 9
shp.top = (i - 1) * 14.25 + 27 + 14.25 / 2 ' 25 + (i - 1) * 14.25 + 1
shp.width = (104 + (Cells(i + 1, 2).Value) * 18 - 9) - (104 + (Cells(i + 2, 2).Value - 1) * 18 + 9)
shp.Rotation = -180 * 7.12 / (3.14 * shp.width / 2) '近似算法,已知弧度、半径求角度
shp.width = (104 + (Cells(i + 1, 2).Value) * 18 - 9) - (104 + (Cells(i + 2, 2).Value - 1) * 18 + 9)
End If
If Cells(i + 1, 2).Value < Cells(i + 2, 2).Value Then
shp.left = 104 + (Cells(i + 1, 2).Value) * 18 - 9
shp.top = 25 + (i - 1) * 14.25 + 1
shp.width = (104 + (Cells(i + 2, 2).Value - 1) * 18 + 9) - (104 + (Cells(i + 1, 2).Value) * 18 - 9)
shp.height = 14.25
End If
If Cells(i + 1, 2).Value = Cells(i + 2, 2).Value Then
shp.left = 104 + (Cells(i + 1, 2).Value) * 18 - 9
shp.top = 25 + (i - 1) * 14.25 + 1
shp.width = 0
shp.height = 14.25
End If
Next
'篮球位置
For i = 1 To 20
Set shp = ActiveSheet.Shapes("blueball" & i)
shp.left = 124 + (Cells(i + 1, 2).Value - 2) * 18
shp.TextFrame2.TextRange.Characters.Text = Cells(i + 1, 2).Value
Next
[T2].Select
End Sub4、向名为ScrollBar2的”滚动条“控件的Change事件粘贴代码。代码如下。
Private Sub ScrollBar2_Change()
Set shp = ActiveSheet.Shapes("Line20")
shp.left = 130 + (ScrollBar2.Value - 1) * 18
End Sub
5、点击”保存“。
6、点击”宏“，执行”批量生成折线和篮球“宏，运行结果如图。
7、点击名为ScrollBar1的”移动条“，运行结果如图。
8、点击名为ScrollBar2的”移动条“，移动红色的竖线，运行结果如图。