Note: The other languages of the website are Google-translated. Back to English
Log in  \/ 
x
or
x
Inscreva-se  \/ 
x

or

Como alterar automaticamente o tamanho da forma com base / dependente do valor da célula especificado no Excel?

Se você deseja alterar automaticamente o tamanho da forma com base no valor de uma célula especificada, este artigo pode ajudá-lo.

Alterar automaticamente o tamanho da forma com base no valor da célula especificado com código VBA


Alterar automaticamente o tamanho da forma com base no valor da célula especificado com código VBA


O código VBA a seguir pode ajudá-lo a alterar um determinado tamanho de forma com base no valor de célula especificado na planilha atual. Faça o seguinte.

1. Clique com o botão direito na guia da folha com a forma necessária para alterar o tamanho e clique em Ver código no menu do botão direito.

2. No Microsoft Visual Basic para Aplicações janela, copie e cole o seguinte código VBA na janela de código.

Código VBA: altera automaticamente o tamanho da forma com base no valor de célula especificado no Excel

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Row = 2 And Target.Column = 1 Then
        Call SizeCircle("Oval 2", Val(Target.Value))
    End If
End Sub
Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

Importante: No código, “Oval 2”É o nome da forma, você alterará seu tamanho. E Linha = 2, Coluna = 1 significa que o tamanho da forma “Oval 2” será alterado com o valor em A2. Altere-os conforme necessário.

Para redimensionar automaticamente várias formas com base em diferentes valores de células, aplique o código VBA abaixo.

Código VBA: redimensiona automaticamente várias formas com base no valor de diferentes células especificadas no Excel

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xAddress As String
    On Error Resume Next
    If Target.CountLarge = 1 Then
        xAddress = Target.Address(0, 0)
        If xAddress = "A1" Then
            Call SizeCircle("Oval 1", Val(Target.Value))
        ElseIf xAddress = "A2" Then
            Call SizeCircle("Smiley Face 3", Val(Target.Value))
        ElseIf xAddress = "A3" Then
            Call SizeCircle("Heart 2", Val(Target.Value))
        End If
    End If
End Sub

Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

notas:

1) No código, “Oval 1","Cara sorridente 3"E"Coração 3”São o nome das formas, você alterará seus tamanhos automaticamente. E A1, A2 eA3 são as células cujos valores você redimensionará automaticamente as formas.
2) Se você quiser adicionar mais formas, adicione linhas "ElseIf xAddress = "A3" Então"E "Chamar SizeCircle (" Heart 2 ", Val (Target.Value))"acima do primeiro"Se acabar"linha no código. E altere o endereço da célula e o nome da forma com base nas suas necessidades.

3. Pressione outro + Q simultaneamente para fechar o Microsoft Visual Basic para Aplicações janela.

A partir de agora, quando você alterar o valor na célula A2, o tamanho da forma Oval 2 será alterado automaticamente. Veja a imagem:

Ou altere os valores nas células A1, A2 e A3 para redimensionar as formas correspondentes "Oval 1", "Smiley Face 3" e "Coração 3" automaticamente. Veja a imagem:

Importante: O tamanho da forma não mudará mais quando o valor da célula for maior que 10.


Liste e exporte todas as formas na pasta de trabalho atual do Excel:

O Exportar Gráficos utilidade de Kutools for Excel ajudá-lo a listar rapidamente todas as formas na pasta de trabalho atual, e você pode exportá-los todos para uma determinada pasta de uma vez, como mostrado na imagem abaixo. Baixe e experimente agora! (Trilha livre de 30 dias)


Artigos relacionados:


As melhores ferramentas de produtividade para escritório

O Kutools for Excel resolve a maioria dos seus problemas e aumenta sua produtividade em 80%

  • armadilha para peixes: Insira rapidamente fórmulas complexas, gráficos e qualquer coisa que você tenha usado antes; Criptografar células com senha; Criar lista de discussão e enviar emails ...
  • Super Formula Bar (edite facilmente várias linhas de texto e fórmula); Layout de leitura (ler e editar facilmente um grande número de células); Colar na faixa filtrada...
  • Mesclar células / linhas / colunas sem perder dados; Dividir o conteúdo das células; Combinar linhas / colunas duplicadas... Evite células duplicadas; Comparar intervalos...
  • Selecione Duplicado ou Único Linhas; Selecione linhas em branco (todas as células estão vazias); Super Find e Fuzzy Find em muitos livros; Seleção aleatória ...
  • Cópia exata Várias células sem alterar a referência da fórmula; Criação automática de referências para várias folhas; Inserir marcadores, Caixas de seleção e mais ...
  • Extrair Texto, Adicionar texto, remover por posição, Remover Espaço; Criar e imprimir subtotais de paginação; Converter entre conteúdo de células e comentários...
  • Super Filtro (salvar e aplicar esquemas de filtro a outras planilhas); Classificação Avançada por mês / semana / dia, frequência e mais; Filtro Especial por negrito, itálico ...
  • Combine pastas de trabalho e planilhas; Mesclar tabelas com base em colunas-chave; Divida os dados em várias folhas; Conversão em lote de xls, xlsx e PDF...
  • Mais de 300 recursos poderosos. Suporta Office / Excel 2007-2019 e 365. Suporta todos os idiomas. Fácil implantação em sua empresa ou organização. Teste gratuito de 30 dias com recursos completos. Garantia de devolução do dinheiro em 60 dias.
guia kte 201905

Guia do Office traz interface com guias para o Office e torna seu trabalho muito mais fácil

  • Habilite a edição e leitura com guias em Word, Excel, PowerPoint, Publisher, Access, Visio e Project.
  • Abra e crie vários documentos em novas guias da mesma janela, em vez de em novas janelas.
  • Aumenta sua produtividade em 50% e reduz centenas de cliques do mouse para você todos os dias!
officetab bottom
Say something here...
symbols left.
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    mathnz · 1 months ago
    is there a way for this to work if the cell your using to set the size is the result of a formula rather than just a static value you manualy enter?
    • To post as a guest, your comment is unpublished.
      crystal · 26 days ago
      Hi mathnz,
      The VBA code below can help you solve the problem.
      You just need to change the value cells and the shape names in the code based on your own data.

      Private Sub Worksheet_Calculate() 'Updated by Extendoffice 20211105 On Error Resume Next Call SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 is the value cell, Oval 1 is the shape name Call SizeCircle("Smiley Face 2", Val(Range("A2").Value)) Call SizeCircle("Heart 3", Val(Range("A3").Value)) End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim xAddress As String On Error Resume Next If Target.CountLarge = 1 Then xAddress = Target.Address(0, 0) If xAddress = "A1" Then Call SizeCircle("Oval 1", Val(Target.Value)) ElseIf xAddress = "A2" Then Call SizeCircle("Smiley Face 2", Val(Target.Value)) ElseIf xAddress = "A3" Then Call SizeCircle("Heart 3", Val(Target.Value)) End If End If End Sub Sub SizeCircle(Name As String, Diameter) Dim xCenterX As Single Dim xCenterY As Single Dim xCircle As Shape Dim xDiameter As Single On Error GoTo ExitSub xDiameter = Diameter If xDiameter > 10 Then xDiameter = 10 If xDiameter < 1 Then xDiameter = 1 Set xCircle = ActiveSheet.Shapes(Name) With xCircle xCenterX = .Left + (.Width / 2) xCenterY = .Top + (.Height / 2) .Width = Application.CentimetersToPoints(xDiameter) .Height = Application.CentimetersToPoints(xDiameter) .Left = xCenterX - (.Width / 2) .Top = xCenterY - (.Height / 2) End With ExitSub: End Sub

  • To post as a guest, your comment is unpublished.
    Chairil · 2 years ago
    Hi Crytal
    what if to determine the side of the cube, triangle, box that must be determined based on the length, width? Please help me

    Thank You
    chairil
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi Chairil,
      Sorry can't help you with that yet. Thanks for your comment.
  • To post as a guest, your comment is unpublished.
    carolgomezgianine@gmail.com · 2 years ago
    Hi Crytal,

    I would like to ask you, if there is a way to select color (red cell = red form) and name from specific cells . could it also be possible to create forms automatically from VBA?

    Thank you so much in advance :)

    Carol


  • To post as a guest, your comment is unpublished.
    Andrew · 3 years ago
    Is there a way to do this with Images? I don't seem to be having any luck using the code as posted.

    5 Images in a leaderboard, I want the Images in 1st or tied for 1st to be larger. Therefore I've 2 fixed image sizes, either 1x2 for not first or 2x4 for 1st placed (for example). I've got ranking already set-up so can use that to create sizes in specific cells for each image (ie use an IF statement so IF RANK is 1st size width is 2). My VBA is pretty weak though.

    Basically I want - on sheet update - look at image size cells and set each image size to the specific image size cells result. I can't see in the VBA above how that exactly works but I think it should be easy!
  • To post as a guest, your comment is unpublished.
    Sam · 3 years ago
    Hi, is there a way that I can make the shape expand on two dimensions (instead of increasing the shape size by 5, increase it 5 on the horizontal and 3 on the vertical)?
    • To post as a guest, your comment is unpublished.
      crystal · 3 years ago
      Dear Sam,
      The following VBA script can help you solve the problem. And the two dimensions are cell A1 and B1.

      Private Sub Worksheet_Change(ByVal Target As Range)
      On Error Resume Next
      If Target.Count = 1 Then
      If Not Intersect(Target, Range("A1:B1")) Is Nothing Then
      Call SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
      End If
      End If
      End Sub
      Sub SizeCircle(Name As String, Arr As Variant)
      Dim I As Long
      Dim xCenterX As Single
      Dim xCenterY As Single
      Dim xCircle As Shape
      On Error GoTo ExitSub
      For I = 0 To UBound(Arr)
      If Arr(I) > 10 Then
      Arr(I) = 10
      ElseIf Arr(I) < 1 Then
      Arr(I) = 1
      End If
      Next
      Set xCircle = ActiveSheet.Shapes(Name)
      With xCircle
      xCenterX = .Left + (.Width / 2)
      xCenterY = .Top + (.Height / 2)
      .Width = Application.CentimetersToPoints(Arr(0))
      .Height = Application.CentimetersToPoints(Arr(1))
      .Left = xCenterX - (.Width / 2)
      .Top = xCenterY - (.Height / 2)
      End With
      ExitSub:
      End Sub
  • To post as a guest, your comment is unpublished.
    Ian · 4 years ago
    Hi,
    I have tried to use your post to write my own VBA code but don't seem to be getting very far. Mainly because I don't really understand VBA and I'm just trying to adapt your. I was wondering if you could help. I am wanting to change the length of a rectangle depending on the value in a cell. I would like the width if the rectangle to stay the same but the length to change. I would like both left hand vertices to stay in the same place and it to lengthen to the right. Is this possible?
    Thank you
    • To post as a guest, your comment is unpublished.
      crystal · 4 years ago
      Dear lan,
      Hope the following VBA code can solve your problem. (Please replace the Oval 1 with the shape name of your own)

      Private Sub Worksheet_Change(ByVal Target As Range)
      On Error Resume Next
      If Target.Row = 2 And Target.Column = 1 Then
      Call SizeCircle("Oval 1", Val(Target.Value))
      End If
      End Sub
      Sub SizeCircle(Name As String, Diameter)
      Dim xCircle As Shape
      Dim xDiameter As Single
      On Error GoTo ExitSub
      xDiameter = Diameter
      If xDiameter > 10 Then xDiameter = 10
      If xDiameter < 1 Then xDiameter = 1
      Set xCircle = ActiveSheet.Shapes(Name)
      xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
      With xCircle
      .LockAspectRatio = msoFalse
      .Width = Application.CentimetersToPoints(xDiameter)
      End With
      ExitSub:
      End Sub
  • To post as a guest, your comment is unpublished.
    Abhinaya · 4 years ago
    Hi, how do i replicate the same for multiple shapes linked to multiple cells in the same module?
    • To post as a guest, your comment is unpublished.
      crystal · 4 years ago
      Dear Abhinaya,
      The article is updated with a new code section which can help you to execute with multiple shapes each depending on different cells. Thank you for your comment.

      Best Regards,
      Crystal
  • To post as a guest, your comment is unpublished.
    Ranjit Konkar · 4 years ago
    How do I name my shape? In your example above, how do you assign the name Oval 2 to the circle you have drawn?
    • To post as a guest, your comment is unpublished.
      crystal · 4 years ago
      Dear Ranjit,
      For naming a shape, please select this shape, enter the shape name into the Name Box, and then press the Enter key. See below image shown.
  • To post as a guest, your comment is unpublished.
    Jade · 4 years ago
    How would you execute this with multiple shapes each depending on different cells?
    • To post as a guest, your comment is unpublished.
      crystal · 4 years ago
      Dear Jade,
      The article is updated with a new code section which can help you to execute with multiple shapes each depending on different cells. Thank you for your comment.

      Best Regards,
      Crystal