模拟Excel2010迷你图

爱疯

这是照着 Excel 2010迷你图效果模拟的，以便方便没装10的朋友。
还请多多指正，改的更有用些，谢谢！


最后一次更新在 8 楼

爱疯

模拟Excel2010迷你图.rar (24.07 KB, 下载次数: 42)

2016-4-9 17:21 上传

点击文件名下载附件

ghostjiao

{:1612:}好厉害

fxgg72

太厉害了啊！
{:1112:}

fxgg72

爱疯 发表于 2016-4-9 17:21

老师是用2010做的，附件也是2010的，我03打不开啊。
还有就是直接用03做效果，步骤和方法咋整？
谢谢！

爱疯

fxgg72 发表于 2016-4-11 16:35
老师是用2010做的，附件也是2010的，我03打不开啊。
还有就是直接用03做效果，步骤和方法咋整？
谢谢！ ...

03下，这句不能用
如果急用就先注释这句。

fxgg72

爱疯 发表于 2016-4-11 17:23
03下，这句不能用
如果急用就先注释这句。

谢谢老师！
太高深了，弄不来，先放放。

爱疯

Sparkline_8.rar (25.87 KB, 下载次数: 25)

2016-4-12 10:23 上传

点击文件名下载附件

重新整理，加了点注释。





'初始化
Sub init()
    If Workbooks.Count = 0 Then End
    If Selection.Count = 1 Then End
    If TypeName(Selection) <> "Range" Then End
    Application.ScreenUpdating = False
    ActiveSheet.DrawingObjects.Delete
    Application.Calculate       '可选
End Sub

'折线图
Sub lineChart()
    Dim rng As Range            '某行的数据源
    Dim maxValue As Double      '某行的最大值
    Dim firstNote As Boolean    'True表示是首节点
    Dim isAddNote As Boolean    'True表示已应用过 AddNodes 方法
    Dim freeForm As FreeformBuilder
    Dim r, c, i, j, l, t, tmp

    Call init
    r = Selection.Rows.Count
    c = Selection.Columns.Count

    For i = 1 To r
        Set rng = Cells(Selection.Row + i - 1, Selection.Column + c)
        maxValue = Application.Max(Application.Index(Selection, i, 0))
        Set freeForm = Nothing: firstNote = False: isAddNote = False

        For j = 1 To c
            tmp = Selection(i, j)
            If tmp = "" Then
                If isAddNote Then freeForm.ConvertToShape.Line.ForeColor.RGB = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
                firstNote = False
                isAddNote = False
            Else
                If VBA.IsNumeric(tmp) = False Then tmp = 0
                'rng.Width/c 表示第几份，再除以2表示该份的中点
                l = rng.Left + rng.Width * (j - 1) / c + rng.Width / c / 2
                '比如30%，+就是下移，下移70%可体现30%的效果
                t = rng.Top + rng.Height * (1 - tmp / maxValue)
                If firstNote = False Then
                    firstNote = True
                    Set freeForm = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, l, t)
                Else
                    isAddNote = True
                    freeForm.AddNodes msoSegmentLine, msoEditingAuto, l, t
                    If j = c Then freeForm.ConvertToShape.Line.ForeColor.RGB = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
                End If
            End If
        Next j
    Next i
End Sub

'柱形图
Sub columnChart()
    Dim rng As Range            '某行的数据源
    Dim maxValue As Double      '某行的最大值
    Dim shpName() As Variant    '图表名称数组
    Dim zoomWidth As Double     '宽度缩小系数
    Dim zoomHeight As Double    '高度缩小系数
    Dim ratio                   '当前值:最大值
    Dim r, c, i, j, tmp, s

    Call init
    r = Selection.Rows.Count
    c = Selection.Columns.Count
    zoomWidth = 0.75
    zoomHeight = 0.92

    For i = 1 To r
        Set rng = Cells(Selection.Row + i - 1, Selection.Column + c)
        maxValue = Application.Max(Application.Index(Selection, i, 0))

        For j = 1 To c
            tmp = Selection(i, j)
            If tmp > 0 Then
                If val(tmp) = tmp Then
                    ratio = tmp / maxValue
                    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                                                     rng.Left + rng.Width * (j - 1) / c, _
                                                     rng.Top + rng.Height * (1 - zoomHeight * ratio), _
                                                     zoomWidth * rng.Width / c, _
                                                     zoomHeight * rng.Height * ratio)
                        .Line.Visible = msoFalse
                        .Fill.ForeColor.RGB = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
                        ReDim Preserve shpName(s): shpName(s) = .Name: s = s + 1
                    End With
                End If
            End If
        Next j

        ActiveSheet.Shapes.Range(shpName).Group
        Erase shpName: s = 0
    Next i
End Sub

小野狼2006

爱疯 发表于 2016-4-12 10:15
重新整理，加了点注释。

好高深啊

雅致如诗的叶子

学习了，谢谢分享