福彩双色球篮球折线图制作的VBA+Excel的方法及其程序

最近，本人连续发布了三篇关于制作福彩双色球动态幻圆图的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 Sub

3、向名为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 Sub

4、向名为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的”移动条“，移动红色的竖线，运行结果如图。