VBA基础

Sub VBA制图表()

    '声明变量
    Dim ws As Worksheet
    Dim Chart_Rng As Range    '声明一个单元格变量
    Dim chObj As ChartObject  '声明一个ChartObject对象变量，代表嵌入在工作表中的一个图表容器
    Dim ch As Chart           '声明一个Chart对象变量，代表图表本身

    Set ws = ThisWorkbook.Sheets("制图")  '设置工作表
    Set Chart_Rng = ws.Range("A1:B11")    '设置源数据范围，品牌在A列、销量在B列

    Set chObj = ws.ChartObjects.Add(Left:=180, Width:=500, Top:=10, Height:=250) ' 在工作表上创建一个新的图表对象(画板)，指定位置和大小
    Set ch = chObj.Chart  '获取内部的Chart对象(画纸)

    '在Chart对象(画纸)上操作，就像画画
    ch.ChartType = xlColumnClustered     '图表类型为簇(cù)状柱形图
    ch.SetSourceData Source:=Chart_Rng   '给图表指定数据源

    ch.HasTitle = True                    '图表标题状态为显示
    ch.ChartTitle.text = "一月份销量"      '图表标题文字

    'ch.HasLegend = True                         '图例状态为显示
    'ch.Legend.Position = xlLegendPositionBottom '图例显示位置在底部
    ch.HasLegend = False                         '不显示图例

    'ch.Axes(xlCategory).HasTitle = True         '设置分类轴(x轴)标题状态为显示
    'ch.Axes(xlCategory).AxisTitle.Text = "品牌" 'x轴标题文字

    With ch.Axes(xlCategory).TickLabels.Font '设置轴标签字体设置
        .Size = 10
        .Bold = True
    End With
    ch.Axes(xlCategory).TickLabels.Orientation = 45 ' 45度角

    ' 设置Y轴（数值轴）的主要网格线 X轴（分类轴）的主要网格线的引用方法.Axes(xlCategory).MajorGridlines.Border
    With ch.Axes(xlValue).MajorGridlines.Border
        .Weight = 1          ' 粗细（磅）
        .color = RGB(100, 0, 0) ' 红色
        .LineStyle = xlDash  ' 虚线（xlSolid=实线，xlDot=点线）
    End With

    '美化数据系列
    Dim srs As Series
    Dim i As Long
    Debug.Print ch.SeriesCollection.Count       '数据系列的个数，当前示例中的数据系列只有一个销量，就返回1

    For Each srs In ch.SeriesCollection         '循环遍历ch.SeriesCollection集合，当前只有一个数据系列，循环一次即可
        Debug.Print srs.Name                    '数据系列的名称
        Debug.Print srs.Points.Count            '数据系列里数据的个数

        For i = 1 To srs.Points.Count           '遍历每个数据标签
            Debug.Print srs.XValues(i)          '打印标签
            Debug.Print srs.Values(i)           '打印值

            If i Mod 2 = 0 Then                 '偶数行我们改变柱体颜色、标签等，这里用奇偶数举例，也可以按照标签、值大小单独设置
                srs.Points(i).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)              '柱体颜色为红色
                'srs.Points(i).ApplyDataLabels                                         '添加数据标签，直接应用并显示数据标签
                srs.Points(i).HasDataLabel = True                                      '启用指定数据点的标签（但不自动显示内容，需额外设置）
                srs.Points(i).DataLabel.text = "※" & srs.Values(i)          '数据标签的文本设置
                With srs.Points(i).DataLabel.Font                                      '数据标签进行设置，颜色、大小、粗细
                    .color = RGB(255, 0, 0)
                    .Size = 10
                    .Bold = True
                End With
                srs.DataLabels.Position = xlLabelPositionOutsideEnd         '数据标签在柱形末端外
            End If
        Next i
    Next srs
    '调整Y轴的数据标签
    With ch.Axes(xlValue)
        Dim Maxvalue As Long
        Maxvalue = Application.WorksheetFunction.Max(ch.SeriesCollection(1).Values) '数据列最大值

        '设置最小值和最大值
        .MinimumScale = 0
        .MaximumScale = Application.WorksheetFunction.Max(ch.SeriesCollection(1).Values) * 1.1 '最大值是数据列最大值的110%

        ' 设置主要刻度单位
        .MajorUnit = (Round((Maxvalue * 1.1 / 5) / 500, 0) + 1) * 500  '将主要刻度分成5等分，刻度线显示500的倍数

        ' 设置刻度线类型
        .MajorTickMark = xlInside
    End With


    '添加注释说明
    Dim maxPoint As Point, minPoint As Point
    Dim maxIndex As Long, minIndex As Long

    Set srs = ch.SeriesCollection(1)                        '当前只有一个数据系列，直接指定它
    For i = 1 To srs.Points.Count                           ' 查找最大值和最小值的位置
        If srs.Values(i) = Maxvalue Then maxIndex = i
        If srs.Values(i) = Application.WorksheetFunction.Min(ch.SeriesCollection(1).Values) Then minIndex = i
    Next i

    Set maxPoint = srs.Points(maxIndex)
    Set minPoint = srs.Points(minIndex)

    ' 添加最大值注释，call调用其他过程
    Call AddDPA(ch, maxPoint, "销量最高: " & Format(Maxvalue, "#,##0"), RGB(0, 150, 0))
    ' 添加最小值注释
    Call AddDPA(ch, minPoint, "销量最低: " & Format(Application.WorksheetFunction.Min(ch.SeriesCollection(1).Values), "#,##0"), RGB(200, 0, 0))

End Sub
' 添加数据点注释的通用函数
Sub AddDPA(ch As Chart, pt As Point, text As String, color As Long)
    Dim shp As Shape, arrow As Shape
    Dim arrowStartX As Double, arrowStartY As Double
    Dim arrowEndX As Double, arrowEndY As Double

    ' 计算数据点中心位置 ，left左，Top上，位置距离的大小是相对图的边框而言
    Dim pointCenterX As Double, pointCenterY As Double
    pointCenterX = pt.Left + pt.Width / 2
    pointCenterY = pt.Top + pt.Height / 2

    ' 确定注释框位置
    Dim boxTop As Double, boxLeft As Double
    boxLeft = pointCenterX - 60
    boxTop = pointCenterY - 70

    ' 添加注释框
    Set shp = ch.Shapes.AddShape(msoShapeRoundedRectangle, boxLeft, boxTop, 90, 20) '90,20是注释框的长和宽
    With shp  '对注释框的修饰
        .TextFrame2.TextRange.text = text      '字体内容
        .TextFrame2.TextRange.Font.Size = 10   '字体大小
        .TextFrame2.TextRange.Font.Bold = True '字体粗细
        .Fill.ForeColor.RGB = color            '字体颜色
        .Fill.Transparency = 0.3  ' 30% 透明   '底色透明度
        .Line.Weight = 0                       '边框线条的粗细
    End With

    ' 添加箭头（从注释框指向数据点）
    arrowStartX = boxLeft + 60
    arrowStartY = boxTop + 40
    arrowEndX = pointCenterX
    arrowEndY = pointCenterY
    Set arrow = ch.Shapes.AddLine(arrowStartX, arrowStartY, arrowEndX, arrowEndY) 'arrowStartX, arrowStartY起始位置的X/Y点，arrowEndX, arrowEndY是结束位置
    With arrow.Line '对线条的修饰
        .ForeColor.RGB = color
        .Weight = 1.5
        .EndArrowheadStyle = msoArrowheadTriangle
        .EndArrowheadWidth = msoArrowheadWidthMedium
        .EndArrowheadLength = msoArrowheadLengthMedium
    End With

End Sub

'一个工作表事件，当前工作表被激活时，就显示(.show)"人员录入"的窗体
'前提是我们在开发时，把应插入到当前表的窗体命名为"人员录入"
Private Sub Worksheet_Activate()
    人员录入.Show
End Sub

' 窗体初始化代码，就是窗体.show初始显示是的部分设置
Private Sub UserForm_Initialize()
    ' 设置学历下拉框选项
   'me表示当前UserForm窗体，Edu_txt是窗体中的一个"控件"的名称
    With Me.Edu_txt
        .AddItem "高中"
        .AddItem "大专"
        .AddItem "本科"
        .AddItem "硕士"
        .AddItem "博士"
    End With

    ' 设置默认在职状态
    Me.OptAct.value = True 'OptAct是窗体中的一个"控件"的名称
End Sub

'btnSubmit是窗体中的一个"控件"的名称，_Click表示按下、单击
'该过程解释，当btnSubmit这个控件被鼠标单击单击时，它会什么？
Private Sub btnSubmit_Click()
' 验证姓名，不满足条件就程序退出过程，规范姓名的录入
    If Trim(Me.Name_txt.value) = "" Then '不能为空
        MsgBox "姓名不能为空！", vbExclamation, "输入错误"
        Me.Name_txt.SetFocus  '定位到姓名录入窗口
        Exit Sub
    ElseIf InStr(Me.Name_txt.value, " ") > 0 Then '不能包含空格
        MsgBox "姓名不能包含空格！", vbExclamation, "输入错误"
        Me.Name_txt.SetFocus
        Exit Sub
    End If

    ' 验证年龄，不满足条件就程序退出过程，规范年龄的录入
    If Not IsNumeric(Me.Age_txt.value) Then  '必须是数值
        MsgBox "年龄必须是数字！", vbExclamation, "输入错误"
        Me.Age_txt.SetFocus
        Exit Sub
    ElseIf Me.Age_txt.value < 18 Or Me.Age_txt.value > 65 Then  '年龄是有范围的
        MsgBox "年龄必须在18-65岁之间！", vbExclamation, "输入错误"
        Me.Age_txt.SetFocus
        Exit Sub
    ElseIf InStr(Me.Age_txt.value, ".") > 0 Then  '年龄是整数
        MsgBox "年龄必须是整数！", vbExclamation, "输入错误"
        Me.Age_txt.SetFocus
        Exit Sub
    End If

    ' 验证学历，它是一个下列框来选择，不能是空值和其它的选择框之外的内容
    If Me.Edu_txt.value = "" Then
        MsgBox "请选择学历！", vbExclamation, "输入错误"
        Me.Edu_txt.SetFocus
        Exit Sub
    End If

    ' 验证在职状态，在职状态是单选，就是三个状态是排它的必选项
    Dim status As String
    If Me.OptAct.value Then
        status = "在职"
    ElseIf Me.OptRes.value Then
        status = "离职"
    ElseIf Me.OptPro.value Then
        status = "试用"
    Else
        MsgBox "请选择在职状态！", vbExclamation, "输入错误"
        Exit Sub
    End If

    ' 添加数据到工作表，如果以上数据验证都，就写入到表格
    Dim ws As Worksheet
    Dim Row_end As Long

    Set ws = ThisWorkbook.Sheets("窗体与插件")
    Row_end = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1 '定位到数据表非空的末行的下一行

    '表格的ABCD列，对应写入姓名、年龄、学历、在职状态等值
    With ws
        .Cells(Row_end, 1).value = Trim(Me.Name_txt.value) '添加姓名
        .Cells(Row_end, 2).value = CInt(Me.Age_txt.value)  '添加年龄
        .Cells(Row_end, 3).value = Me.Edu_txt.value        '添加学历
        .Cells(Row_end, 4).value = status                  '添加状态

    End With
    ’最后弹出“成功”的消息框反馈给用户，并清空窗体的文本框便于继续维护
    MsgBox "员工信息添加成功！"

    ' 清空表单，恢复到初始状态，清空表单是一个单独的过程，调用即可！
    Call btnClear_Click
End Sub

' 清空表单的过程代码，恢复到初始状态，它也是一个btnClear控件下的代码
Private Sub btnClear_Click()
    Me.Name_txt.value = ""
    Me.Age_txt.value = ""
    Me.Edu_txt.value = ""
    Me.OptAct.value = True  '在职状态为默认
    Me.Name_txt.SetFocus     '姓名录入窗口为当前窗口
End Sub

' 关闭按钮代码，btnClose控件，单击后的代码
Private Sub btnClose_Click()
    Unload Me '取消加载就是隐藏Me（当前）的这个窗体
End Sub

Sub office协同Excel_Word()
    '自定义数据类型
    Dim Choose_rng As Range
    Dim wdap

    On Error Resume Next
    '选择需要设置的单元格区域，把单元格区域设置为可选择，普适性会更好
    Set Choose_rng = Application.InputBox("选择需要设置的单元格或单元格区域", Type:=8)
    If WorksheetFunction.CountA(Choose_rng) = 0 Then MsgBox "选择单元格区域为空": Exit Sub
    On Error GoTo 0

    Application.ScreenUpdating = False '关闭刷新
    Application.DisplayAlerts = False  '关闭警告

    Set wdap = CreateObject("Word.Application") ' 创建 Word 应用
    With wdap
        .Visible = True
        .Documents.Add  '添加一个word表
    End With

    Choose_rng.Copy  '复制表黏贴到Word文档
    wdap.Selection.Paste

    wdap.Selection.WholeStory  '复制word文档的内容
    wdap.Selection.Copy

    '当前工作簿新建一个表命名为“复制表存放”并粘贴
    ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Sheets(Sheets.Count).Name = "复制表存放"
    ThisWorkbook.Sheets("复制表存放").Range("A1").Select
    ActiveSheet.Paste

    wdap.Documents.Close False '不保存关闭word表
    wdap.Quit                  '退出Word应用，未保存且退出，相当于未留下Word文档的痕迹

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

MsgBox "完成"
End Sub