全民一起VBA提高篇第八课：图形界面设计二

简单窗体

功能要求：

1. 能通过窗体显示数据
2. 能通过窗体添加数据
3. 能通过窗体修改数据
4. 能通过窗体删除信息

图片演示效果

显示数据

添加数据

修改数据

删除数据

代码实现

窗体设置，拖动各个控件，并把对应的caption以及名称修改以便后用

界面中首先添加控件

Sub 显示列表框3()
UserForm3.Show
End Sub

初始化

Private Sub UserForm_Initialize()
    Dim i As Long
    Dim r As Range
   Set r = Worksheets(2).UsedRange
   'worksheets(2)不能忘，这一句用于确定r的范围
   i = r.Row + r.Rows.Count - 1
   '读取r用于给i赋值，能够找到添加数据的起始位置
    ComboBox1.RowSource = "b2:b" & i
    '用于给复合框添加数据源，这一步是初始化中完成的
    '顺序不能搞错
    TextBox1 = Cells(2, 11)
    '这几个单元格存放的值是固定用的几个最大值
    '求最大值我是在工作表中间用的自带函数max
    '没有写在VBA代码中
    'VBA只需要进行传参就行了
    TextBox2 = Cells(2, 12)
    TextBox3 = Cells(2, 13)
    TextBox4 = Cells(2, 14)
    TextBox5 = Cells(2, 15)
End Sub

显示信息

Private Sub ComboBox1_Change()
Dim i As Long

 If ComboBox1.ListIndex > -1 Then
 '读取下拉框数据变化时
 '对应的读取数据跟着i变化
     i = ComboBox1.ListIndex + 2
     政治.Text = Cells(i, 3)
     数学.Text = Cells(i, 4)
     英语.Text = Cells(i, 5)
     专业课.Text = Cells(i, 6)
     总分.Text = Cells(i, 7)
     本科院校.Text = Cells(i, 8)
     
 End If
End Sub

添加信息

Private Sub 添加信息_Click()
Dim r As Range, i As Long
    
    Set r = Worksheets(2).UsedRange
    'worksheets(1)不能省略
    
    i = r.Row + r.Rows.Count
    If 姓名.Text <> "" Then
    Cells(i, 2) = 姓名.Text
    '将输入窗体里的数据传递给表格中
    '这里的姓名是添加字段后面的输入框，不是姓名后面的
    '所以输入也得在添加字段后面输入
    Cells(i, 3) = 政治.Text
    Cells(i, 4) = 数学.Text
    Cells(i, 5) = 英语.Text
    Cells(i, 6) = 专业课.Text
    Cells(i, 7) = CInt(政治.Text) + CInt(数学.Text) + CInt(英语.Text) + CInt(专业课.Text)
    '传的参数都是字符串，这里需要强制转换一下
    Cells(i, 8) = 本科院校.Text
    'i表示当前表格最后一行数据的下一行
    姓名.Text = ""
    '当添加完毕后，让窗体中的数据清零
    政治.Text = ""
    数学.Text = ""
    英语.Text = ""
    专业课.Text = ""
    总分.Text = ""
    本科院校.Text = ""
    End If
End Sub

修改信息

Private Sub 修改信息_Click()
Dim i As Long
Dim j As Long

   
 If ComboBox1.ListIndex > -1 Then
   i = ComboBox1.ListIndex + 2
   'i用来定位，保证对应在下拉框中选中的字段所在的位置
   j = MsgBox("修改第" & i & "行数据，是否确定？", vbYesNo)
   '点确定传的数字就是6
    If j = 6 Then
    Cells(i, 3) = 政治.Text
    Cells(i, 4) = 数学.Text
    Cells(i, 5) = 英语.Text
    Cells(i, 6) = 专业课.Text
    Cells(i, 7) = CInt(政治.Text) + CInt(数学.Text) + CInt(英语.Text) + CInt(专业课.Text)
    Cells(i, 8) = 本科院校.Text
    End If
    End If
End Sub

删除信息

Private Sub 删除信息_Click()
Dim i As Long

Dim j, r

    If ComboBox1.ListIndex > -1 Then
 
        i = ComboBox1.ListIndex + 2
        j = MsgBox("删除第" & i & "行数据，是否确定？", vbYesNo)
        '同上，确定对应的数字是6
            If j = 6 Then
                Rows(i).Delete
                '删掉整行，删除后，后面的数据补上，
                '而每次的i都是随用随读取
                '所以不用担心影响到其他地方的使用
            End If
    End If
End Sub

批量生成图表

单击任意数据源中的数据，弹出对应的折线图

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim mychart As ChartObject, ws As Worksheet, row As Long

Set ws = Worksheets("sheet2")

    row = Target.row
    
    If row < 13 And row > 2 Then
        If ws.ChartObjects.Count = 0 Then
        '如果现在没有图表，就新建一个
            Set mychart = ws.ChartObjects.Add(80, 240, 300, 200)
            '前2个代表左边距和上边距，后两个代表表的长和宽
        Else
            Set mychart = ws.ChartObjects(1)
            '如果有了，就把mychart指向该图表
        End If
        
        With mychart.Chart
        '定义mychart下面的chart属性
            
            .ChartType = xlLine
        '生成折线图
            .SetSourceData Source:=Range(ws.Cells(row, 3), ws.Cells(row, 12))
        '数据源
            .HasTitle = True
            '写标题
            .ChartTitle.Text = ws.Cells(row, 2)
            '没有上一句话这句话执行不了
        End With
    End If
        
End Sub

批量生成折线图

很遗憾，下面的几个代码在EXCEL2016中执行不了，我是在EXCEL2007中跑的
但是听课时老师的范例是在2016中运行的，问题我之后再想办法解决

单击数据源生成图表

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim mychart As ChartObject, ws As Worksheet, row As Double

Set ws = Worksheets("sheet1")

    row = Target.row
    
    If row < 13 And row > 2 Then
        If ws.ChartObjects.Count = 0 Then
        '如果现在没有图表，就新建一个
            Set mychart = ws.ChartObjects.Add(80, 240, 300, 200)
            '前2个代表左边距和上边距，后两个代表表的长和宽
        Else
            Set mychart = ws.ChartObjects(1)
            '如果有了，就把mychart指向该图表
        End If
        
        With mychart.Chart
        '定义mychart下面的chart属性
            
            .ChartType = xlLine
        '生成折线图
            .SetSourceData Source:=Range(ws.Cells(row, 4), ws.Cells(row, 15))
        '数据源
            .HasTitle = True
            '写标题
            .ChartTitle.Text = ws.Cells(row, 2)
            '没有上一句话这句话执行不了
        End With
    End If
        
End Sub

批量生成图表

Sub 批量生成折线图()
Dim mychart As ChartObject, ws As Worksheet
Dim i As Long, j As Long
Set ws = Worksheets("sheet1")

   If ws.ChartObjects.Count > 0 Then
   ws.ChartObjects.Delete
   End If
       
   For i = 3 To 12
  
    Set mychart = ws.ChartObjects.Add(((i - 3) Mod 3) * 350 + 50, (Int((i - 3) / 3) + 1) * 250, 300, 200)
            '前2个代表左边距和上边距，后两个代表表的长和宽
  
        With mychart.Chart
        '定义myChart下面的chart属性
            
            .ChartType = xlLine
        '生成折线图
            .SetSourceData Source:=Range(ws.Cells(i, 4), ws.Cells(i, 15))
        '数据源
            .HasTitle = True
            '写标题
            .ChartTitle.Text = ws.Cells(i, 3)
            '没有上一句话这句话执行不了
        End With
    Next i
        
End Sub

批量输出图表

Sub 输出折线图()

Dim mychart As ChartObject

For Each mychart In Worksheets("sheet1").ChartObjects
'扫描每一个图表

    If mychart.Chart.HasTitle Then
    
        mychart.Chart.Export "d:\" & mychart.Chart.ChartTitle.Text & ".jpg"
    '输出每个图表,用export语法，输出名字带标题，还要加上后缀名
    
    End If
    
Next mychart

End Sub