香港新浪網 MySinaBlog
« 上一篇 | 下一篇 »
Emily | 15th Sep 2006, 14:03 PM | WB & WS | (2497 Reads)

Cell Charting

Scaled-in-cell-charting

http://www.dailydoseofexcel.com/archives/2006/09/13/scaled-in-cell-charting/

emoticon

Usage:  =linechart(A3:E3,203,$A$3:$E$8) ' A3:E8 numeric data, 203 is RGB value

Function LineChart(Points As Range, Color As Long, Optional VerticalScale As Range) As String
    
    Dim rCaller As Range
    Dim avNames() As Variant
    Dim i As Long, j As Long, k As Long
    Dim dMin As Double, dMax As Double, dScaleMin As Double, dScaleMax As Double
    Dim shp As Shape
    Dim rScale As Range
    Dim dEffWidth As Double, dEffHeight As Double, dEffBottom As Double, dEffLeft As Double
    
    Const lMARGIN As Long = 2
    Set rCaller = Application.Caller
    ShapeDelete rCaller
    'If VerticalScale Is Nothing Then
    '    Set rScale = Points
    'Else
    '    Set rScale = VerticalScale
    'End If
    If VerticalScale Is Nothing Then
        Set rScale = Points
    Else
        If Not Application.Intersect(Points, VerticalScale) Is Nothing Then
            If Application.Intersect(Points, VerticalScale).Address = _
                Points.Address Then
                Set rScale = VerticalScale
            Else
                Set rScale = Application.Union(Points, VerticalScale)
            End If
        Else
            Set rScale = Application.Union(Points, VerticalScale)
        End If
    End If
 
    With Application.WorksheetFunction
        dMin = .Min(Points)
        dMax = .Max(Points)
        dScaleMin = .Min(rScale)
        dScaleMax = .Max(rScale)
    End With
   
    dEffWidth = rCaller.Width - (lMARGIN * 2)
    dEffHeight = rCaller.Height - (lMARGIN * 2)
    dEffBottom = rCaller.Top + lMARGIN + dEffHeight
    dEffLeft = rCaller.Left + lMARGIN
   
    With rCaller.Worksheet.Shapes
        For i = 0 To Points.Count - 2
           Set shp = .AddLine( _
                dEffLeft + (i * (dEffWidth) / (Points.Count - 1)), _
                dEffBottom - (dEffHeight * (Points(, i + 1) - dScaleMin + 1) / (dScaleMax - dScaleMin + 1)), _
                dEffLeft + ((i + 1) * (dEffWidth) / (Points.Count - 1)), _
                dEffBottom - (dEffHeight * (Points(, i + 2) - dScaleMin + 1) / (dScaleMax - dScaleMin + 1)))
 
            On Error Resume Next
                j = 0
                j = UBound(avNames) + 1
            On Error GoTo 0
            ReDim Preserve
avNames(j)
            avNames(j) = shp.Name
        Next
        With
rCaller.Worksheet.Shapes.Range(avNames)
            .Group
            .Line.ForeColor.RGB = Abs(Color)
        End With
    End With

    LineChart = ""
   
End Function
 
Sub
ShapeDelete(rngSelect As Range)
    Dim rng As Range, shp As Shape, blnDelete As Boolean
 
    For Each shp In rngSelect.Worksheet.Shapes
        blnDelete = False
        Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
        If Not rng Is Nothing Then
            If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
        End If
        If
blnDelete Then shp.Delete
    Next
End Sub


[1] 学习

您好,谢谢你的提醒,我已经更改了哦..
不介意我经常引用你的文章吧


[引用] | 作者 excelme | 18th Sep 2006 18:55 PM | [舉報垃圾留言]