Criar gráfico velocímetro automaticamente VBA Excel

Histograma Excel
Como criar um Histograma no Excel
21 de junho de 2015
Análise de indicadores no Excel com o recurso Câmera e uso de VBA
Análise de indicadores no Excel com o recurso Câmera e uso de VBA
1 de julho de 2015

Objetivo: Disponibilizar uma macro para criar automaticamente um gráfico de velocímetro Excel VBA.

Gráfico velocímetro Excel VBA 1

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.

Gráfico velocímetro Excel VBA 1

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.

GUT PPT

Abraço

Marcos Rieper


Clique aqui e leia mais sobre Excel VBA. https://www.guiadoexcel.com.br/vba/ O Guia do Excel foi criado por Marcos Rieper e oferece artigos, dicas, tutoriais e modelos de planilhas prontas. Aqui você encontra tudo sobre Excel, seja de nível básico, intermediário,  avançado e VBA. O Guia do Excel oferece diversos materiais completamente gratuitos para download. Navegue em nosso site e confira! Conheça também a nossa Loja do Excel https://loja.guiadoexcel.com.br/

15 Comentários

  1. Marcelo disse:

    Olá, fiz o passo-a-passo para criação do projeto do gráfico velocímetro, porém, ao executar a Macro surgiu uma mensagem de erro “Método ou membro de dados não encontrado”

    • Marcos Rieper disse:

      Boa tarde Marcelo,

      Obrigado pelo seu contato.

      Realizei um teste e funcionou aqui.

      Você está executado a função lsCriarGrafico? Ele vai ao depurador quando ocorre este problema?

      Abraço

      Marcos Rieper

  2. Milton disse:

    Tive o mesmo problema, o depurador para na linha 224, col 37 e seleciona .FullSeriesCollection

  3. André disse:

    Bom dia Marcos, muito legal essa macro, mas não consegui rodar no meu excel 2010, veja o erro que aparece:

    Ln 213, Col 1
    Sub lsGraficoRosca(ByVal lNomePlanilha As String, ByRef lGrafico1 As String)

    Consegue me ajudar?

  4. Rafael disse:

    Estou com o mesmo problema do André. A mensagem de erro é a seguinte:

    Erro de Compilação – Método ou membro de dados não encontrado.

    O depurador indica erro nesse comando:

    Sub lsGraficoRosca(ByVal lNomePlanilha As String, ByRef lGrafico1 As String)

    E nesta seleção – .FullSeriesCollection(1)

    Tentei alterar os valores:
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.FullSeriesCollection(1).Values = “=” & lNomePlanilha & “!$B$10:$B$13”
    ActiveChart.FullSeriesCollection(1).Values = “=” & lNomePlanilha & “!$B$10:$B$13”
    ActiveChart.FullSeriesCollection(1).XValues = “=” & lNomePlanilha & “!$A$9:$A$13”

    Mas não deu certo…

    • Marcos Rieper disse:

      Bom dia Rafael,

      Obrigado pelo aviso, você pode me mandar qual a sua versão do Excel?

      Você está fazendo o download da planilha e testando diretamente por ela ou usando somente o código?

      Abraço

      Marcos Rieper

  5. gildo gomes guarda disse:

    Olá, boa tarde! Estou tentando baixar o arquivo da “Faixa personalizada do guia excel”, mas dá um erro, diz que não está disponivel. Tem como me enviar?

  6. JOAO NETO disse:

    Sub lsGraficoRosca(ByVal lNomePlanilha As String, ByRef lGrafico1 As String)

    “Método de membro não encontrado.”

    Excel 2010

Deixe uma resposta

O seu endereço de e-mail não será publicado. Campos obrigatórios são marcados com *

Esse site utiliza o Akismet para reduzir spam. Aprenda como seus dados de comentários são processados.

Inscreva-se no nosso canal do Youtube!


Junte-se ao nosso canal do Youtube. Começamos em abril de 2016, mas já temos mais de 06:00 h de treinamentos gratuitos e este número irá aumentar. Vídeos novos todos os sábados.