Views

Histats

Vitrine

VBA Excel - Criando um gráfico por célula usando VBA - Create an In Cell Chart Using VBA.

Inline image 1

Nos nossos Scorecards ou Dashboards às vezes talvez seja interessante que estéticamente mantenhamos um gráfico de linhas simples em cada uma das linhas de um determinado conjunto de dados de uma planilha qualquer. 

Inline image 2

Esse efeito fica bom quando poucas linhas são utilizadas, como se fosse um pequeno resumo. Mas certamente a sua criatividade o ajudará a ampliar a utilização deste recurso.

A seguir descreverei como criar um gráfico em uma célula

O gráfico é criado usando uma função chamada ChartInCell. Você terá que digitar uma função no MS Excel, como qualquer outra função MÉDIA, SUM, ou VLOOKUP.

Esta função não é uma função padrão disponível no MS Excel, deve ser criado pelo usuário usando VBA.

'Creates a new function called Cell Chart
Function ChartInCell (Plots 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 Plots.Count
        If j = 0 Then
            j = i
        ElseIf Plots(, j) > Plots(, i) Then
            j = i
        End If
        If k = 0 Then
            k = i
        ElseIf Plots(, k) < Plots(, i) Then
            k = i
        End If
    Next
    dblMin = Plots(, j)
    dblMax = Plots(, k)

     With rng.Worksheet.Shapes
        For i = 0 To Plots.Count - 2
            Set shp = .AddLine( _
                cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Plots.Count - 1)), _
                cMargin + rng.Top + (dblMax - Plots(, i + 1)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
                cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Plots.Count - 1)), _
                cMargin + rng.Top + (dblMax - Plots(, 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

    CellChart = ""
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


Referências: Automateexcel.com

Tags: VBA, Excel, cell, chart, gráfico, célula, display, user defined, workbook

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...