VBA学习(5):批量生成小饼图

之前给大家分享了如何用一个函数制作各种常见图表，之后有朋友问，下图中表示精确占比的饼图是怎么批量生成的？

批量生成小饼图有两种常用的方法，一种是用插件，比如Sparklines；另外一种是自己动手丰衣足食，摊手，也就写点VBA小代码得啦。

复制运行以下VBA代码，选择占比值所在的单元格区域，即可批量生成小饼图。

Sub vbaPie()
    Dim cht As ChartObject, rngData As Range, rng As Range
    On Error Resume Next
    For Each cht In ActiveSheet.ChartObjects '删除旧图
        If InStr(cht.Name, "公众号Excel星球") Then cht.Delete
    Next
    Set rngData = Application.InputBox("请选择数据区域", Default:=Selection.Address, Type:=8)
    If Err Then Exit Sub
    rngData.Parent.Select
    Set rngData = Intersect(rngData, ActiveSheet.UsedRange)
    If rngData Is Nothing Then MsgBox "请选择有效数据区域": Exit Sub
    For Each rng In rngData '遍历单元格
        Call CreateCht(rng, Array(rng.Value, 1 - rng.Value))
    Next
    rngData(1).Select
End Sub

Function CreateCht(rng As Range, aRef)
    On Error Resume Next
    Dim cht As ChartObject
    Set cht = ActiveSheet.ChartObjects.Add(100, 100, 200, 200)
    With cht.Chart '图表
        .ChartType = xlPie '指定图表类型
        .SeriesCollection.NewSeries '新系列
        .SeriesCollection (1)
        With .SeriesCollection(1)
            .Values = aRef '数据
            .Points(1).Format.Fill.ForeColor.RGB = RGB(64, 64, 64) '占比颜色
            .Points(2).Format.Fill.ForeColor.RGB = RGB(166, 166, 166) '其它占比颜色
        End With
        .ApplyDataLabels -xlDataLabelsShowNone '干掉标签
        .Legend.Delete '干掉图例
        .ChartTitle.Delete '干掉标题
        With .PlotArea '设置绘图区大小
            .Select
            .Top = 0
            .Height = 170
            .Width = 170
            .Left = 0
        End With
    End With
    cht.Name = "看见星光" & rng.Address  '图表命名
    With ActiveSheet.Shapes(cht.Name)
        .Fill.Visible = msoFalse '取消填充色
        .Line.Visible = msoFalse '取消线条色
        .Height = rng.Height '高
        .Width = rng.Height '宽
        .Top = rng.Top + 1 '位置top
        .Left = rng.Left + 1 '位置left
    End With
End Function

技术交流，软件开发，欢迎微信沟通：