✔ VBA Dashboards Specialist®: VBA Excel - Criando um gráfico por célula usando VBA

2 de abril de 2012

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

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