Note: The other languages of the website are Google-translated. Back to English

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

Nota: 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:

Nota: 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! (30-dia de trilha livre)


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 ...
  • Barra Super Fórmula (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-2021 e 365. Suporta todos os idiomas. Fácil implantação em sua empresa ou organização. Recursos completos de avaliação gratuita de 30 dias. 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!
parte inferior da aba do escritório
Comentários (16)
Ainda não há classificações. Seja o primeiro a avaliar!
Este comentário foi feito pelo moderador no site
Como você executaria isso com várias formas, cada uma dependendo de células diferentes?
Este comentário foi feito pelo moderador no site
Prezado Jade,
O artigo é atualizado com uma nova seção de código que pode ajudá-lo a executar com várias formas, cada uma dependendo de células diferentes. Obrigado pelo seu comentário.

Atenciosamente,
Cristal
Este comentário foi feito pelo moderador no site
Como nomear minha forma? No seu exemplo acima, como você atribui o nome Oval 2 ao círculo que você desenhou?
Este comentário foi feito pelo moderador no site
Prezado Ranjit,
Para nomear uma forma, selecione esta forma, insira o nome da forma na caixa de nome e pressione a tecla Enter. Veja abaixo a imagem mostrada.
Este comentário foi feito pelo moderador no site
Oi, como faço para replicar o mesmo para várias formas vinculadas a várias células no mesmo módulo?
Este comentário foi feito pelo moderador no site
Prezado Abhinaya,
O artigo é atualizado com uma nova seção de código que pode ajudá-lo a executar com várias formas, cada uma dependendo de células diferentes. Obrigado pelo seu comentário.

Atenciosamente,
Cristal
Este comentário foi feito pelo moderador no site
Oi,
Eu tentei usar seu post para escrever meu próprio código VBA, mas não parece estar indo muito longe. Principalmente porque eu não entendo muito de VBA e estou apenas tentando adaptar o seu. Eu queria saber se você poderia ajudar. Estou querendo alterar o comprimento de um retângulo dependendo do valor em uma célula. Eu gostaria que a largura do retângulo permanecesse a mesma, mas o comprimento mudasse. Eu gostaria que os dois vértices da mão esquerda ficassem no mesmo lugar e se alongassem para a direita. Isso é possível?
Obrigado
Este comentário foi feito pelo moderador no site
Caro lan,
Espero que o seguinte código VBA possa resolver seu problema. (Por favor, substitua o Oval 1 pelo nome da forma de sua preferência)

Private Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Se Target.Row = 2 e Target.Column = 1 Then
Call SizeCircle("Oval 1", Val(Target.Value))
Se acabar
End Sub
Sub SizeCircle (Nome como String, Diâmetro)
Escurecer xCírculo como forma
Dim xDiâmetro como único
Em erro GoTo ExitSub
xDiâmetro = Diâmetro
Se xDiameter > 10 Então xDiameter = 10
Se xDiameter < 1 Então xDiameter = 1
Definir xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Com xCírculo
.LockAspectRatio = msoFalse
.Width = Application.CentimetersToPoints(xDiameter)
Terminar com
ExitSub:
End Sub
Este comentário foi feito pelo moderador no site
Oi, existe uma maneira de fazer a forma expandir em duas dimensões (em vez de aumentar o tamanho da forma em 5, aumente 5 na horizontal e 3 na vertical)?
Este comentário foi feito pelo moderador no site
Caro sam,
O script VBA a seguir pode ajudá-lo a resolver o problema. E as duas dimensões são as células A1 e B1.

Private Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Se Target.Count = 1 Então
If Not Intersect(Target, Range("A1:B1")) Não é Nada Então
Call SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
Se acabar
Se acabar
End Sub
Sub SizeCircle(Nome como String, Arr Como Variante)
Escurecer eu enquanto
Dim xCenterX como único
Dim xCenterY como único
Escurecer xCírculo como forma
Em erro GoTo ExitSub
Para I = 0 Para UBound(Arr)
Se Arr(I) > 10 Então
Arr(I) = 10
ElseIf Arr(I) < 1 Then
Arr(I) = 1
Se acabar
Seguinte
Definir xCircle = ActiveSheet.Shapes(Name)
Com xCírculo
xCenterX = .Esquerda + (.Largura / 2)
xCenterY = .Top + (.Height / 2)
.Width = Application.CentimetersToPoints(Arr(0))
.Altura = Aplicação.CentímetrosParaPontos(Arr(1))
.Esquerda = xCenterX - (.Largura / 2)
.Topo = xCenterY - (.Altura / 2)
Terminar com
ExitSub:
End Sub
Este comentário foi feito pelo moderador no site
Existe uma maneira de fazer isso com imagens? Eu não pareço estar tendo sorte usando o código como postado.

5 Imagens em uma tabela de classificação, quero que as imagens em 1º ou empatadas em 1º sejam maiores. Portanto, tenho 2 tamanhos de imagem fixos, 1x2 para não primeiro ou 2x4 para 1º colocado (por exemplo). Eu tenho a classificação já configurada, então posso usar isso para criar tamanhos em células específicas para cada imagem (ou seja, use uma instrução IF para que IF RANK seja o 1º tamanho de largura seja 2). Meu VBA é muito fraco embora.

Basicamente, eu quero - na atualização da planilha - olhar para as células do tamanho da imagem e definir cada tamanho da imagem para o resultado específico das células do tamanho da imagem. Não consigo ver no VBA acima como isso funciona exatamente, mas acho que deve ser fácil!
Este comentário foi feito pelo moderador no site
Olá Cristal,

Gostaria de perguntar se existe uma maneira de selecionar a cor (célula vermelha = forma vermelha) e o nome de células específicas. também seria possível criar formulários automaticamente a partir do VBA?

Muito obrigado antecipadamente :)

cântico
Este comentário foi feito pelo moderador no site
Oi Cristal
e se para determinar o lado do cubo, triângulo, caixa que deve ser determinado com base no comprimento, largura? Por favor me ajude

Obrigado
cadeira
Este comentário foi feito pelo moderador no site
Olá Chairil,
Desculpe, não posso ajudá-lo com isso ainda. Obrigado por seu comentário.
Este comentário foi feito pelo moderador no site
existe uma maneira de isso funcionar se a célula que você está usando para definir o tamanho for o resultado de uma fórmula em vez de apenas um valor estático inserido manualmente?
Este comentário foi feito pelo moderador no site
Oi mathnz, O código VBA abaixo pode ajudá-lo a resolver o problema. Você só precisa alterar as células de valor e os nomes das formas no código com base em seus próprios dados.
Sub Planilha Privada_Calcular()
'Atualizado por Extendoffice 20211105
On Error Resume Next
Call SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 é a célula de valor, Oval 1 é o nome da forma
Call SizeCircle("Carinha Sorridente 2", Val(Range("A2").Value))
Call SizeCircle("Coração 3", Val(Range("A3").Value))

End Sub
Private Sub Worksheet_Change (ByVal Target As Range)
Dim xAddress como String
On Error Resume Next
Se Target.CountLarge = 1 Então
xAddress = Target.Address(0, 0)
Se xAddress = "A1" Então
Call SizeCircle("Oval 1", Val(Target.Value))
ElseIf xAddress = "A2" Então
Call SizeCircle("Smiley Face 2", Val(Target.Value))
ElseIf xAddress = "A3" Então
Call SizeCircle("Coração 3", Val(Target.Value))

Se acabar
Se acabar
End Sub

Sub SizeCircle (Nome como String, Diâmetro)
Dim xCenterX como único
Dim xCenterY como único
Escurecer xCírculo como forma
Dim xDiâmetro como único
Em erro GoTo ExitSub
xDiâmetro = Diâmetro
Se xDiameter > 10 Então xDiameter = 10
Se xDiameter < 1 Então xDiameter = 1
Definir xCircle = ActiveSheet.Shapes(Name)
Com xCírculo
xCenterX = .Esquerda + (.Largura / 2)
xCenterY = .Top + (.Height / 2)
.Width = Application.CentimetersToPoints(xDiameter)
.Altura = Aplicação.CentímetrosParaPontos(xDiâmetro)
.Esquerda = xCenterX - (.Largura / 2)
.Topo = xCenterY - (.Altura / 2)
Terminar com
ExitSub:
End Sub

Não há comentários postados aqui ainda
Deixe o seu comentário
Postando como convidado
×
Avalie esta postagem:
0   Personagens
Locais sugeridos

Siga-nos

Copyright © 2009 - www.extendoffice.com. | Todos os direitos reservados. Distribuído por ExtendOffice. | | | Mapa do site
Microsoft e o logotipo do Office são marcas comerciais ou marcas registradas da Microsoft Corporation nos Estados Unidos e / ou em outros países.
Protegido por Sectigo SSL