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

Hur ändrar jag formstorlek automatiskt / beroende på angivet cellvärde i Excel?

Om du vill ändra formstorleken automatiskt baserat på värdet för en viss cell kan den här artikeln hjälpa dig.

Ändra formstorlek automatiskt baserat på specificerat cellvärde med VBA-kod


Ändra formstorlek automatiskt baserat på specificerat cellvärde med VBA-kod

Följande VBA-kod kan hjälpa dig att ändra en viss formstorlek baserat på det angivna cellvärdet i det aktuella kalkylbladet. Gör så här.

1. Högerklicka på arkfliken med den form du behöver för att ändra storlek och klicka sedan på Visa kod från högerklickmenyn.

2. I Microsoft Visual Basic för applikationer fönster, kopiera och klistra in följande VBA-kod i kodfönstret.

VBA-kod: Ändra formstorlek automatiskt baserat på specificerat cellvärde i 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

Anmärkningar: I koden, “Oval 2”Är det formnamn du kommer att ändra storlek. Och Rad = 2, Kolumn = 1 betyder att storleken på formen ”Oval 2” kommer att ändras med värdet i A2. Ändra dem efter behov.

För att automatiskt ändra storlek på flera former baserat på olika cellvärden, använd nedanstående VBA-kod.

VBA-kod: Ändra storlek på flera former automatiskt baserat på olika angivna cellvärden i 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

Anmärkningar:

1) I koden, “Oval 1","Smiley 3"Och"Hjärta 3”Är formens namn. Du kommer att ändra storlek automatiskt. Och A1, A2 ochA3 är cellerna vilka värden du automatiskt ändrar storlek baserat på.
2) Om du vill lägga till fler former, vänligen lägg till rader "ElseIf xAddress = "A3" Sedan"och "Call SizeCircle (" Heart 2 ", Val (Target.Value))"ovanför den första"End If"rad i koden. Och ändra celladressen och formnamnet baserat på dina behov.

3. Tryck andra + Q samtidigt för att stänga Microsoft Visual Basic för applikationer fönster.

Från och med nu, när du ändrar värdet i cell A2, ändras storleken på formen Oval 2 automatiskt. Se skärmdump:

Eller ändra värdena i cellerna A1, A2 och A3 för att ändra storlek på motsvarande former "Oval 1", "Smiley Face 3" och "Heart 3" automatiskt. Se skärmdump:

Anmärkningar: Formstorleken ändras inte längre när cellvärdet är större än 10.


Lista och exportera alla former i aktuell Excel-arbetsbok:

Du har nu möjlighet Exportera grafik nytta av Kutools för Excel hjälper dig att snabbt lista alla former i aktuell arbetsbok, och du kan exportera dem alla till en viss mapp samtidigt som skärmdumpen nedan visar. Ladda ner och prova nu! (30- dag gratis spår)


Relaterade artiklar:


De bästa Office-produktivitetsverktygen

Kutools för Excel löser de flesta av dina problem och ökar din produktivitet med 80%

  • återanvändning: Sätt snabbt i komplexa formler, diagram och allt som du har använt tidigare; Kryptera celler med lösenord; Skapa e-postlista och skicka e-post ...
  • Super Formula Bar (enkelt redigera flera rader med text och formel); Läslayout (enkelt läsa och redigera ett stort antal celler); Klistra in i filtrerat intervall...
  • Sammanfoga celler / rader / kolumner utan att förlora data; Delat cellinnehåll; Kombinera duplicerade rader / kolumner... Förhindra duplicerade celler; Jämför intervall...
  • Välj Duplicera eller Unikt Rader; Välj tomma rader (alla celler är tomma); Super Find och Fuzzy Find i många arbetsböcker; Slumpmässigt val ...
  • Exakt kopia Flera celler utan att ändra formelreferens; Skapa referenser automatiskt till flera ark; Sätt in kulor, Kryssrutor och mer ...
  • Extrahera text, Lägg till text, ta bort efter position, Ta bort mellanslag; Skapa och skriva ut personsökningstalsatser; Konvertera mellan celler innehåll och kommentarer...
  • Superfilter (spara och tillämpa filterscheman på andra ark); Avancerad sortering efter månad / vecka / dag, frekvens och mer; Specialfilter av fet, kursiv ...
  • Kombinera arbetsböcker och arbetsblad; Sammanfoga tabeller baserat på nyckelkolumner; Dela data i flera ark; Batchkonvertera xls, xlsx och PDF...
  • Mer än 300 kraftfulla funktioner. Stöder Office / Excel 2007-2021 och 365. Stöder alla språk. Enkel implementering i ditt företag eller organisation. Fullständiga funktioner 30 dagars gratis provperiod. 60 dagars pengarna tillbaka-garanti.
kte-flik 201905

Fliken Office ger ett flikgränssnitt till Office och gör ditt arbete mycket enklare

  • Aktivera flikredigering och läsning i Word, Excel, PowerPoint, Publisher, Access, Visio och Project.
  • Öppna och skapa flera dokument i nya flikar i samma fönster, snarare än i nya fönster.
  • Ökar din produktivitet med 50 % och minskar hundratals musklick för dig varje dag!
officetab botten
Sortera kommentarer efter
Kommentarer (16)
Inga betyg än. Bli först med att betygsätta!
Denna kommentar minimerades av moderatoren på webbplatsen
Hur skulle du utföra detta med flera former var och en beroende på olika celler?
Denna kommentar minimerades av moderatoren på webbplatsen
Kära Jade,
Artikeln är uppdaterad med ett nytt kodavsnitt som kan hjälpa dig att köra med flera former var och en beroende på olika celler. Tack för din kommentar.

Bästa hälsningar,
Kristall
Denna kommentar minimerades av moderatoren på webbplatsen
Hur namnger jag min form? I ditt exempel ovan, hur tilldelar du namnet Oval 2 till cirkeln du har ritat?
Denna kommentar minimerades av moderatoren på webbplatsen
Kära Ranjit,
För att namnge en form, välj den här formen, skriv in formens namn i namnrutan och tryck sedan på Enter. Se bilden nedan.
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, hur replikerar jag detsamma för flera former kopplade till flera celler i samma modul?
Denna kommentar minimerades av moderatoren på webbplatsen
Kära Abhinaya,
Artikeln är uppdaterad med ett nytt kodavsnitt som kan hjälpa dig att köra med flera former var och en beroende på olika celler. Tack för din kommentar.

Bästa hälsningar,
Kristall
Denna kommentar minimerades av moderatoren på webbplatsen
Hej,
Jag har försökt använda ditt inlägg för att skriva min egen VBA-kod men det verkar inte komma särskilt långt. Främst för att jag inte riktigt förstår VBA och jag försöker bara anpassa din. Jag undrade om du kunde hjälpa. Jag vill ändra längden på en rektangel beroende på värdet i en cell. Jag skulle vilja att bredden om rektangeln förblir densamma men att längden ändras. Jag skulle vilja att båda vänstra hörnen stannar på samma plats och att den förlängs åt höger. Är detta möjligt?
Tack
Denna kommentar minimerades av moderatoren på webbplatsen
Kära lan,
Hoppas följande VBA-kod kan lösa ditt problem. (Vänligen ersätt Oval 1 med ditt eget formnamn)

Privata delarkivsförändring (ByVal-mål som område)
On Error Resume Next
Om Target.Row = 2 Och Target.Column = 1 Då
Call SizeCircle("Oval 1", Val(Target.Value))
End If
End Sub
Sub SizeCircle(Namn som sträng, diameter)
Dim xCircle As Shape
Dim xDiameter Som Singel
Vid fel GoTo ExitSub
xDiameter = Diameter
Om xDiameter > 10 Då är xDiameter = 10
Om xDiameter < 1 Då är xDiameter = 1
Ställ in xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Med xCircle
.LockAspectRatio = msoFalse
.Width = Application.CentimetersToPoints(xDiameter)
Sluta med
ExitSub:
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, finns det något sätt att få formen att expandera i två dimensioner (istället för att öka formstorleken med 5, öka den med 5 på den horisontella och 3 på den vertikala)?
Denna kommentar minimerades av moderatoren på webbplatsen
Kära Sam,
Följande VBA-skript kan hjälpa dig att lösa problemet. Och de två dimensionerna är cell A1 och B1.

Privata delarkivsförändring (ByVal-mål som område)
On Error Resume Next
Om Target.Count = 1 Då
If Not Intersect(Target, Range("A1:B1")) är ingenting då
Call SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
End If
End If
End Sub
Sub SizeCircle(Namn som sträng, Arr som variant)
Dim I As Long
Dim xCenterX Som Singel
Dim xCenterY Som Singel
Dim xCircle As Shape
Vid fel GoTo ExitSub
För I = 0 Till UBound(Arr)
Om Arr(I) > 10 Då
Arr(I) = 10
ElseIf Arr(I) < 1 Then
Arr(I) = 1
End If
Nästa
Ställ in xCircle = ActiveSheet.Shapes(Name)
Med 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)
Sluta med
ExitSub:
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Finns det något sätt att göra detta med bilder? Jag verkar inte ha någon tur med att använda koden som postat.

5 bilder på en topplista, jag vill att bilderna i 1:an eller delade på 1:an ska vara större. Därför har jag 2 fasta bildstorlekar, antingen 1x2 för inte först eller 2x4 för 1:a placerad (till exempel). Jag har redan konfigurerat rankning så jag kan använda det för att skapa storlekar i specifika celler för varje bild (dvs. använd en IF-sats så att IF RANK är 1:a storlekens bredd är 2). Min VBA är dock ganska svag.

I grund och botten vill jag - på arkuppdatering - titta på bildstorleksceller och ställa in varje bildstorlek till det specifika cellresultatet i bildstorleken. Jag kan inte se i VBA ovan hur det fungerar exakt men jag tror att det borde vara enkelt!
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Crystal,

Jag skulle vilja fråga dig om det finns ett sätt att välja färg (röd cell = röd form) och namn från specifika celler. kan det också vara möjligt att skapa formulär automatiskt från VBA?

Tack så mycket på förhand :)

Carol
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Crystal
vad händer om man ska bestämma sidan av kuben, triangeln, lådan som måste bestämmas baserat på längden, bredden? Snälla hjälp mig

Tack
stolil
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Chairil,
Jag kan tyvärr inte hjälpa dig med det än. Tack för din kommentar.
Denna kommentar minimerades av moderatoren på webbplatsen
finns det något sätt för detta att fungera om cellen du använder för att ställa in storleken är resultatet av en formel snarare än bara ett statiskt värde du anger manuellt?
Denna kommentar minimerades av moderatoren på webbplatsen
Hej mathnz, VBA-koden nedan kan hjälpa dig att lösa problemet. Du behöver bara ändra värdecellerna och formnamnen i koden baserat på dina egna data.
Private Sub Worksheet_Calculate()
'Uppdaterad av Extendoffice 20211105
On Error Resume Next
Call SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 är värdecellen, Oval 1 är formnamnet
Ring SizeCircle("Smiley Face 2", Val(Range("A2").Value))
Call SizeCircle("Hjärta 3", Val(Range("A3").Value))

End Sub
Privata delarkivsförändring (ByVal-mål som område)
Dim xAddress As String
On Error Resume Next
Om Target.CountLarge = 1 Då
xAddress = Target.Address(0, 0)
Om xAddress = "A1" Då
Call SizeCircle("Oval 1", Val(Target.Value))
ElseIf xAddress = "A2" Sedan
Ring SizeCircle("Smiley Face 2", Val(Target.Value))
ElseIf xAddress = "A3" Sedan
Ring SizeCircle("Hjärta 3", Val(Target.Value))

End If
End If
End Sub

Sub SizeCircle(Namn som sträng, diameter)
Dim xCenterX Som Singel
Dim xCenterY Som Singel
Dim xCircle As Shape
Dim xDiameter Som Singel
Vid fel GoTo ExitSub
xDiameter = Diameter
Om xDiameter > 10 Då är xDiameter = 10
Om xDiameter < 1 Då är xDiameter = 1
Ställ in xCircle = ActiveSheet.Shapes(Name)
Med 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)
Sluta med
ExitSub:
End Sub

Det finns inga kommentarer här ännu
Lämna dina kommentarer
Postar som gäst
×
Betygsätt detta inlägg:
0   Tecken
Föreslagna platser

Följ oss

Copyright © 2009 - www.extendoffice.com. | Alla rättigheter förbehållna. Drivs av ExtendOffice. | | Sitemap
Microsoft och Office-logotypen är varumärken eller registrerade varumärken som tillhör Microsoft Corporation i USA och / eller andra länder.
Skyddad av Sectigo SSL