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)
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.
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
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?
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!
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)?
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
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
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
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.
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.
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.
