Dicas de Tipo de Gr...
 
Notifications
Clear all

Dicas de Tipo de Gráfico  

  RSS

Fernando Fernandes
(@fernandofernandes)
Illustrious Member
Entrou: 12 anos atrás
Posts: 44273
11/08/2009 8:21 am  

Bom dia Pessoal!

Navegando pelo mundo do WWW, achei esses 2 links que vale a pena ver:

http://www.juiceanalytics.com/writing/more-on-excel-in-cell-graphing/
Onde tem o arquivo:
http://media.juiceanalytics.com/downloads/Excel%20in-cell%20graphing%20ideas.xls

E o link
http://www.dailydoseofexcel.com/archive ... -charting/

Que tem esse código:

Function LineChart(Points As Range, Color As Long) As String
    Const cMargin = 2
    Dim rng As Range, arr() As Variant, i As Long, j As Long, k As Long
    Dim dblMin As Double, dblMax As Double, shp As Shape
 
    Set rng = Application.Caller
 
    ShapeDelete rng
 
    For i = 1 To Points.Count
        If j = 0 Then
            j = i
        ElseIf Points(, j)> Points(, i) Then
            j = i
        End If
        If k = 0 Then
            k = i
        ElseIf Points(, k) <Points(, i) Then
            k = i
        End If
    Next
    dblMin = Points(, j)
    dblMax = Points(, k)
 
    With rng.Worksheet.Shapes
        For i = 0 To Points.Count - 2
            Set shp = .AddLine( _
                cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
                cMargin + rng.Top + (dblMax - Points(, i + 1)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
                cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
                cMargin + rng.Top + (dblMax - Points(, i + 2)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin))
 
            On Error Resume Next
            j = 0: j = UBound(arr) + 1
            On Error GoTo 0
            ReDim Preserve arr(j)
            arr(j) = shp.Name
        Next
 
        With rng.Worksheet.Shapes.Range(arr)
            .Group
 
            If Color> 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -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

Espero que gostem!!!

Att, Binario!

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel


ResponderCitar (Quote)
Fernando Fernandes
(@fernandofernandes)
Illustrious Member
Entrou: 12 anos atrás
Posts: 44273
11/08/2009 8:26 am  

Outro código mto Legal!!!

Esse é de Barras

Function BarChart(Points As Range, Color As Long) As String
    
    Const cMargin = 2, cGap = 1
    Dim rng As Range, arr() As Variant, i As Long, j As Long, sng As Double, sngIntv As Single
    Dim sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single
    Dim sngMin As Single, sngMax As Single, shp As Shape

    Set rng = Application.Caller

    ShapeDelete rng

    sngMin = WorksheetFunction.Min(Points)
    sngMax = WorksheetFunction.Max(Points)
    If sngMin > 0 Then sngMin = 0

    With rng.Worksheet.Shapes
        For i = 0 To Points.Count - 1
            sng = Points(, i + 1)
            sngIntv = (rng.Height - (cMargin * 2)) / (sngMax - sngMin)
            sngLeft = cMargin + cGap + rng.Left + (i * (rng.Width - (cMargin * 2)) / Points.Count)
            sngTop = cMargin + rng.Top + (sngMax - IIf(sng < 0, 0, sng)) * sngIntv
            sngWidth = (rng.Width - (cMargin * 2)) / Points.Count - (cGap * 2)
            sngHeight = Abs(sng) * sngIntv
            Set shp = .AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight)

            On Error Resume Next
            j = 0: j = UBound(arr) + 1
            On Error GoTo 0
            ReDim Preserve arr(j)
            arr(j) = shp.Name
        Next

        With rng.Worksheet.Shapes.Range(arr)
            .Group

            If Color > 0 Then .Fill.ForeColor.RGB = Color Else .Fill.ForeColor.SchemeColor = -Color
        End With

    End With

    BarChart = ""

End Function

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel


ResponderCitar (Quote)
Fernando Fernandes
(@fernandofernandes)
Illustrious Member
Entrou: 12 anos atrás
Posts: 44273
11/08/2009 10:31 am  

Mais um função perdida pela Internet!

Function DataBar(lngValue As Long)
     DataBar = String(lngValue, ChrW(9608))
End Function

http://datapigtechnologies.com/blog/index.php/data-bars-in-excel-2003-without-rept/

Att, Binario

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel


ResponderCitar (Quote)
Compartilhar: