Criar gráfico velocímetro automaticamente VBA Excel

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:

Baixe a planilha

Avalie este post