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

Termo de Responsabilidade

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. 

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