Objetivo: Disponibilizar uma macro para criar automaticamente um gráfico de velocímetro Excel VBA.
A criação do gráfico de velocímetro já foi explicado no artigo: http://guiadoexcel.com.br/grafico-de-ponteiro-excel.
Porém a criação deste gráfico é muito custosa, pois ela demanda um bom tempo e uma boa estrutura, dado que há tabelas padrões e cálculos a serem criados.
Como este gráfico não é nativo do Excel, criei este código VBA para criar quantos gráficos de velocímetro Excel que você precisar.
Para isto você só tem que seguir os passos do tutorial: http://guiadoexcel.com.br/habilitando-a-guia-desenvolvedor-e-copiando-procedimentos-vba-sub-da-internet e colar o código abaixo na sua pasta personal:
Sub lsTabelas()
Range("A1").Select
ActiveCell.FormulaR1C1 = "Categoria"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Ruim"
Range("A3").Select
ActiveCell.FormulaR1C1 = "Regular"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Bom"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Ótimo"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Resultado"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Máximo"
Range("B2").Select
ActiveCell.FormulaR1C1 = "4"
Range("B3").Select
ActiveCell.FormulaR1C1 = "6.5"
Range("B4").Select
ActiveCell.FormulaR1C1 = "9"
Range("B5").Select
ActiveCell.FormulaR1C1 = "10"
Range("B6").Select
ActiveCell.FormulaR1C1 = "8.5"
Range("A8").Select
ActiveCell.FormulaR1C1 = "Mostrador"
Range("A9").Select
ActiveCell.FormulaR1C1 = ""
Range("A10").Select
ActiveCell.FormulaR1C1 = "Ruim"
Range("A11").Select
ActiveCell.FormulaR1C1 = "Regular"
Range("A12").Select
ActiveCell.FormulaR1C1 = "Bom"
Range("A13").Select
ActiveCell.FormulaR1C1 = "Ótimo"
Range("B8").Select
ActiveCell.FormulaR1C1 = "Amplitude"
Range("B9").Select
ActiveCell.FormulaR1C1 = "10"
Range("B10").Select
ActiveCell.FormulaR1C1 = "4"
Range("B11").Select
ActiveCell.FormulaR1C1 = "2.5"
Range("B12").Select
ActiveCell.FormulaR1C1 = "2.5"
Range("B13").Select
ActiveCell.FormulaR1C1 = "1"
Range("A16").Select
ActiveCell.FormulaR1C1 = "Agulha"
Range("A17").Select
ActiveCell.FormulaR1C1 = "Base"
Range("A18").Select
ActiveCell.FormulaR1C1 = "0"
Range("A19").Select
ActiveCell.FormulaR1C1 = "=- COS(PI() * ABS(R6C2 / R9C2))"
Range("B17").Select
ActiveCell.FormulaR1C1 = "Extremidade"
Range("B18").Select
ActiveCell.FormulaR1C1 = "0"
Range("B19").Select
ActiveCell.FormulaR1C1 = "=SIN(PI() * ABS(R6C2 / R9C2))"
Range("A6:B6").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
End Sub
Sub lsPonteiro(ByVal lNomePlanilha As String, ByRef lGrafico2 As String)
Dim lNome As String
ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
lNome = Replace(ActiveChart.Name, ActiveSheet.Name & " ", "")
lGrafico2 = lNome
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(1).Name = "=" & lNomePlanilha & "!$A$16"
ActiveChart.FullSeriesCollection(1).XValues = "=" & lNomePlanilha & "!$A$18:$A$19"
ActiveChart.FullSeriesCollection(1).Values = "=" & lNomePlanilha & "!$B$18:$B$19"
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).MinimumScale = -1
ActiveChart.Axes(xlValue).MaximumScale = 1
ActiveChart.Axes(xlValue).CrossesAt = 0
ActiveChart.Axes(xlValue).MajorUnit = 0.1
ActiveChart.Axes(xlValue).Crosses = xlAutomatic
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).MinimumScale = -1
ActiveChart.Axes(xlCategory).MaximumScale = 1
ActiveChart.Axes(xlCategory).CrossesAt = 0
ActiveChart.Axes(xlCategory).MajorUnit = 0.1
ActiveChart.Axes(xlCategory).Crosses = xlAutomatic
Application.CommandBars("Format Object").Visible = False
ActiveChart.ChartTitle.Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.Axes(xlValue).Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.Axes(xlCategory).Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.Axes(1).MajorGridlines.Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.FullSeriesCollection(1).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(51, 51, 51)
End With
ActiveChart.ChartArea.Select
'Selection.Format.Line.EndArrowheadStyle = msoArrowheadTriangle
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.FullSeriesCollection(1).Points(2).Select
Selection.MarkerStyle = -4142
ActiveChart.FullSeriesCollection(1).Points(1).Select
With Selection
.MarkerStyle = 8
.MarkerSize = 5
End With
Selection.MarkerSize = 6
ActiveChart.ChartArea.Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
Application.CommandBars("Format Object").Visible = False
ActiveSheet.Shapes(lNome).Fill.Visible = msoFalse
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.Axes(2).MajorGridlines.Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.FullSeriesCollection(1).Points(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.Transparency = 0
.Solid
End With
Selection.MarkerSize = 9
ActiveChart.FullSeriesCollection(1).Points(2).Select
'Selection.Format.Line.EndArrowheadStyle = msoArrowheadTriangle
Application.CommandBars("Format Object").Visible = False
ActiveChart.ChartArea.Select
With Selection.Format.Line
.EndArrowheadLength = msoArrowheadLong
.EndArrowheadWidth = msoArrowheadWide
End With
ActiveSheet.Shapes(lNome).ScaleWidth 0.6583333333, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes(lNome).ScaleHeight 0.7413192622, msoFalse, _
msoScaleFromBottomRight
ActiveSheet.Shapes(lNome).IncrementLeft 270.75
ActiveSheet.Shapes(lNome).IncrementTop -72
ActiveSheet.Shapes(lNome).ScaleWidth 1.0348101266, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes(lNome).ScaleHeight 1.3536308011, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes(lNome).IncrementLeft -50.25
ActiveSheet.Shapes(lNome).IncrementTop 0.75
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.FullSeriesCollection(1).Points(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
End With
ActiveChart.ChartArea.Select
Application.CommandBars("Format Object").Visible = False
ActiveSheet.Shapes(lNome).Line.Visible = msoFalse
Range("F10").Select
ActiveSheet.Shapes(lNome).Select
ActiveChart.ChartArea.Select
ActiveSheet.Shapes(lNome).IncrementLeft -160.5
ActiveSheet.Shapes(lNome).IncrementTop 11.25
ActiveSheet.Shapes(lNome).ScaleWidth 0.8318042813, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes(lNome).ScaleHeight 0.8788924143, msoFalse, _
msoScaleFromBottomRight
ActiveSheet.Shapes(lNome).ScaleWidth 0.8161768566, msoFalse, _
msoScaleFromBottomRight
ActiveSheet.Shapes(lNome).ScaleHeight 0.8543307087, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes(lNome).IncrementLeft 1.5
ActiveSheet.Shapes(lNome).IncrementTop 3
Range("E2").Select
End Sub
Sub lsCriarGrafico()
Dim lNomePlanilha As String
Dim lGrafico1 As String
Dim lGrafico2 As String
lsCriarPlanilha lNomePlanilha
lsTabelas
lsGraficoRosca lNomePlanilha, lGrafico1
lsPonteiro lNomePlanilha, lGrafico2
lsAgrupar lGrafico1, lGrafico2
End Sub
Sub lsGraficoRosca(ByVal lNomePlanilha As String, ByRef lGrafico1 As String)
Dim lNome As String
Range("G1").Select
ActiveSheet.Shapes.AddChart2(251, xlDoughnut).Select
lNome = Replace(ActiveChart.Name, ActiveSheet.Name & " ", "")
lGrafico1 = lNome
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(1).Values = "=" & lNomePlanilha & "!$B$9:$B$14"
ActiveChart.FullSeriesCollection(1).Values = "=" & lNomePlanilha & "!$B$9:$B$13"
ActiveChart.FullSeriesCollection(1).XValues = "=" & lNomePlanilha & "!$A$9:$A$13"
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.ChartArea.Select
ActiveChart.PlotArea.Select
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.ChartGroups(1).FirstSliceAngle = 90
ActiveChart.ChartGroups(1).DoughnutHoleSize = 50
ActiveChart.ChartArea.Select
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.ChartGroups(1).FirstSliceAngle = 90
ActiveChart.FullSeriesCollection(1).Points(1).Select
ActiveChart.ChartGroups(1).FirstSliceAngle = 90
Selection.Format.Fill.Visible = msoFalse
ActiveChart.ChartGroups(1).FirstSliceAngle = 90
ActiveChart.Legend.Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.ChartTitle.Select
Selection.Delete
ActiveSheet.ChartObjects(lNome).Activate
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.ChartGroups(1).FirstSliceAngle = 90
ActiveChart.FullSeriesCollection(1).ApplyDataLabels
ActiveChart.ChartGroups(1).FirstSliceAngle = 90
ActiveChart.FullSeriesCollection(1).DataLabels.Select
Selection.ShowCategoryName = True
Selection.ShowValue = False
ActiveChart.ChartArea.Select
Range("J7").Select
End Sub
Sub lsCriarPlanilha(ByRef lNomePlanilha As String)
Sheets.Add
ActiveSheet.Name = "Velocimetro" & Sheets.Count
lNomePlanilha = "Velocimetro" & Sheets.Count
End Sub
Sub lsAgrupar(ByVal lGrafico1 As String, ByVal lGrafico2 As String)
ActiveSheet.ChartObjects(lGrafico1).Activate
ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2")).Select
Selection.ShapeRange.Group.Select
Range("P14").Select
End Sub
Para criar o gráfico vá na guia Desenvolvedor -> Macros e escolha a macro Personal.XLSB!lsCriarGrafico e clique em Executar.
O código irá criar uma nova planilha e criar um novo gráfico de velocímetro.
No botão de download deste artigo você pode baixar um exemplo que cria estes gráficos ao pressionar o botão.
O resultado que temos então é a criação automática do velocímetro quando executa esta macro.
Criando então a tabela com os dados que precisa e também com o gráfico criado automaticamente com base nestes dados.
A tabela acima tem então a estrutura do gráfico para que possa ser criado o gráfico de velocímetro.
Após criado, pode copiar a sua tabela e o gráfico e colocar em outra planilha, ou copiar e colar a estrutura e criar novos gráficos.
O valor que precisa ser alterado para mudar o ponteiro do gráfico é o campo Resultado, nele você terá então a mudança da agulha conforme as categorias Ruim, Regular, Bom e Ótimo.
Se quiser também pode mudar as amplitudes conforme deseja ou mudar os nomes das categorias do gráfico.
O gráfico pode também ser alterado conforme desejar para mudar as cores ou distâncias e largura do gráfico.
Download Planilha Velocímetro VBA
Clique no botão abaixo para realizar o download do arquivo de exemplo: