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

Hoe verander je de vormgrootte automatisch op basis van / afhankelijk van de opgegeven celwaarde in Excel?

Als u de vormgrootte automatisch wilt wijzigen op basis van de waarde van een opgegeven cel, kan dit artikel u helpen.

Verander de vormgrootte automatisch op basis van de opgegeven celwaarde met VBA-code


Verander de vormgrootte automatisch op basis van de opgegeven celwaarde met VBA-code

De volgende VBA-code kan u helpen om een ​​bepaalde vormgrootte te wijzigen op basis van de opgegeven celwaarde in het huidige werkblad. Ga als volgt te werk.

1. Klik met de rechtermuisknop op de bladtab met de vorm waarvan u de grootte wilt wijzigen, en klik vervolgens Bekijk code vanuit het rechtsklikmenu.

2. In de Microsoft Visual Basic voor toepassingen venster, kopieer en plak de volgende VBA-code in het codevenster.

VBA-code: verander de vormgrootte automatisch op basis van de opgegeven celwaarde in 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

Opmerking:: In de code, "Ovaal 2”Is de vormnaam waarvan u de grootte wilt wijzigen. En Rij = 2, Kolom = 1 betekent dat de grootte van vorm "Ovaal 2" wordt gewijzigd met de waarde in A2. Wijzig ze indien nodig.

Pas de onderstaande VBA-code toe om het formaat van meerdere vormen automatisch te wijzigen op basis van verschillende celwaarden.

VBA-code: het formaat van meerdere vormen automatisch wijzigen op basis van de waarde van verschillende gespecificeerde cellen in 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

Opmerkingen:

1) In de code, "Ovaal 1","Smileygezicht 3"En"Hart 3”Is de naam van de vormen, verandert u hun grootte automatisch. En A1, A2 enA3 zijn de cellen waarvan u de grootte van vormen automatisch wijzigt op basis van.
2) Als je meer vormen wilt toevoegen, voeg dan lijnen toe "ElseIf xAddress = "A3" Dan"en "Call SizeCircle (" Heart 2 ", Val (Target.Value))"boven de eerste"End If"regel in de code. En verander het celadres en de vormnaam op basis van uw behoeften.

3. druk op anders + Q toetsen tegelijk om het Microsoft Visual Basic voor toepassingen venster.

Vanaf nu, wanneer u de waarde in cel A2 wijzigt, wordt de grootte van vorm Oval 2 automatisch gewijzigd. Zie screenshot:

Of verander de waarden in cel A1, A2 en A3 om de corresponderende vormen "Ovaal 1", "Smileygezicht 3" en "Hart 3" automatisch aan te passen. Zie screenshot:

Opmerking:: De vormgrootte verandert niet langer wanneer de celwaarde groter is dan 10.


Maak een lijst van en exporteer alle vormen in de huidige Excel-werkmap:

De Exporteer afbeeldingen nut van Kutools for Excel helpen u snel alle vormen in de huidige werkmap weer te geven, en u kunt ze allemaal tegelijk naar een bepaalde map exporteren, zoals de onderstaande schermafbeelding laat zien. Download en probeer het nu! (30-dag vrij parcours)


Gerelateerde artikelen:


De beste tools voor kantoorproductiviteit

Kutools voor Excel lost de meeste van uw problemen op en verhoogt uw productiviteit met 80%

  • visfuik: Snel invoegen complexe formules, grafieken en alles wat je eerder hebt gebruikt; Versleutel cellen met wachtwoord; Maak een mailinglijst en stuur e-mails ...
  • Super Formula-balk (bewerk eenvoudig meerdere regels tekst en formule); Lay-out lezen (gemakkelijk grote aantallen cellen lezen en bewerken); Plakken in gefilterd bereik...
  • Voeg cellen / rijen / kolommen samen zonder gegevens te verliezen; Gespleten cellen inhoud; Combineer dubbele rijen / kolommen... Voorkom dubbele cellen; Vergelijk Ranges...
  • Selecteer Dupliceren of Uniek Rijen; Selecteer lege rijen (alle cellen zijn leeg); Super zoeken en fuzzy zoeken in veel werkboeken; Willekeurige selectie ...
  • Exacte kopie Meerdere cellen zonder de formuleverwijzing te wijzigen; Maak automatisch verwijzingen naar meerdere bladen; Plaats kogels, Selectievakjes en meer ...
  • Extraheer tekst, Tekst toevoegen, Verwijderen op positie, Ruimte verwijderen; Paging-subtotalen maken en afdrukken; Converteren tussen celinhoud en opmerkingen...
  • Super filter (bewaar en pas filterschema's toe op andere bladen); Geavanceerd sorteren per maand / week / dag, frequentie en meer; Speciaal filter door vet, cursief ...
  • Combineer werkmappen en werkbladen; Tabellen samenvoegen op basis van sleutelkolommen; Gegevens splitsen in meerdere bladen; Batch Converteer xls, xlsx en PDF...
  • Meer dan 300 krachtige functies. Ondersteunt Office / Excel 2007-2021 en 365. Ondersteunt alle talen. Eenvoudig te implementeren in uw onderneming of organisatie. Volledige functies Gratis proefperiode van 30 dagen. 60 dagen geld-terug-garantie.
kte tabblad 201905

Office-tabblad Brengt een interface met tabbladen naar Office en maakt uw werk veel gemakkelijker

  • Schakel bewerken en lezen met tabbladen in Word, Excel, PowerPoint in, Publisher, Access, Visio en Project.
  • Open en maak meerdere documenten in nieuwe tabbladen van hetzelfde venster in plaats van in nieuwe vensters.
  • Verhoogt uw productiviteit met 50% en vermindert honderden muisklikken voor u elke dag!
officetab onderkant
Heb je vragen? Stel ze hier. (16)
Nog geen beoordelingen. Beoordeel als eerste!
Deze opmerking is gemaakt door de moderator op de site
Hoe zou je dit uitvoeren met meerdere vormen, elk afhankelijk van verschillende cellen?
Deze opmerking is gemaakt door de moderator op de site
Beste Jade,
Het artikel is bijgewerkt met een nieuwe codesectie die u kan helpen bij het uitvoeren van meerdere vormen, elk afhankelijk van verschillende cellen. Bedankt voor je reactie.

Met vriendelijke groet,
Kristal
Deze opmerking is gemaakt door de moderator op de site
Hoe noem ik mijn vorm? Hoe wijs je in je voorbeeld hierboven de naam Ovaal 2 toe aan de cirkel die je hebt getekend?
Deze opmerking is gemaakt door de moderator op de site
Beste Ranjit,
Om een ​​vorm een ​​naam te geven, selecteert u deze vorm, voert u de vormnaam in het naamvak in en drukt u vervolgens op de Enter-toets. Zie onderstaande afbeelding getoond.
Deze opmerking is gemaakt door de moderator op de site
Hallo, hoe repliceer ik hetzelfde voor meerdere vormen die zijn gekoppeld aan meerdere cellen in dezelfde module?
Deze opmerking is gemaakt door de moderator op de site
Beste Abhinaya,
Het artikel is bijgewerkt met een nieuwe codesectie die u kan helpen bij het uitvoeren van meerdere vormen, elk afhankelijk van verschillende cellen. Bedankt voor je reactie.

Met vriendelijke groet,
Kristal
Deze opmerking is gemaakt door de moderator op de site
Hoi,
Ik heb geprobeerd je bericht te gebruiken om mijn eigen VBA-code te schrijven, maar het lijkt niet ver te komen. Voornamelijk omdat ik VBA niet echt begrijp en ik je alleen probeer aan te passen. Ik vroeg me af of je kon helpen. Ik wil de lengte van een rechthoek wijzigen, afhankelijk van de waarde in een cel. Ik zou graag willen dat de breedte van de rechthoek hetzelfde blijft, maar de lengte verandert. Ik zou willen dat beide linkerhoekpunten op dezelfde plaats blijven en dat ze naar rechts langer worden. Is dit mogelijk?
Bedankt
Deze opmerking is gemaakt door de moderator op de site
Beste lan,
Ik hoop dat de volgende VBA-code uw probleem kan oplossen. (Vervang de Oval 1 door de naam van uw eigen vorm)

Particulier subwerkblad_Wijziging (ByVal-doel als bereik)
On Error Resume Next
Als Target.Rij = 2 en Target.Column = 1 Dan
Call SizeCircle("Ovaal 1", Val(Target.Value))
End If
End Sub
Submaatcirkel (naam als string, diameter)
Dim xCirkel als vorm
Dim xDiameter als enkel
Bij fout GoTo ExitSub
xDiameter = Diameter
Als xDiameter > 10 Dan is xDiameter = 10
Als xDiameter < 1 Dan xDiameter = 1
Stel xCircle = ActiveSheet.Shapes (Naam) in
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Met xCircle
.LockAspectRatio = msoFalse
.Breedte = Application.CentimetersToPoints(xDiameter)
Eindigt met
ExitSub:
End Sub
Deze opmerking is gemaakt door de moderator op de site
Hallo, is er een manier om de vorm in twee dimensies uit te breiden (in plaats van de vorm met 5 te vergroten, 5 op de horizontale en 3 op de verticale)?
Deze opmerking is gemaakt door de moderator op de site
Lieve Sam,
Het volgende VBA-script kan u helpen het probleem op te lossen. En de twee dimensies zijn cel A1 en B1.

Particulier subwerkblad_Wijziging (ByVal-doel als bereik)
On Error Resume Next
Als Target.Count = 1 Dan
Als niet snijden (doel, bereik ("A1: B1")) is niets dan
Bel SizeCircle("Ovaal 2", Array(Val(Bereik("A1").Waarde), Val(Bereik("B1").Waarde)))
End If
End If
End Sub
Sub SizeCircle (naam als string, Arr als variant)
Dim ik zo lang
Dim xCenterX als single
Dim xCenterY als single
Dim xCirkel als vorm
Bij fout GoTo ExitSub
Voor I = 0 Naar UBound (Arr)
Als Arr(I) > 10 Dan
Arr(I) = 10
ElseIf Arr(I) < 1 Dan
Arr(I) = 1
End If
Volgende
Stel xCircle = ActiveSheet.Shapes (Naam) in
Met xCircle
xCenterX = .Links + (.Breedte / 2)
xCenterY = .Boven + (.Hoogte / 2)
.Breedte = Application.CentimetersToPoints(Arr(0))
.Hoogte = Toepassing.CentimetersToPoints(Arr(1))
.Links = xCenterX - (.Breedte / 2)
.Boven = xCenterY - (.Hoogte / 2)
Eindigt met
ExitSub:
End Sub
Deze opmerking is gemaakt door de moderator op de site
Is er een manier om dit met afbeeldingen te doen? Ik schijn geen geluk te hebben met het gebruik van de code zoals gepost.

5 afbeeldingen in een leaderboard, ik wil dat de afbeeldingen in de 1e of gelijk zijn voor de 1e groter zijn. Daarom heb ik 2 vaste afbeeldingsformaten, ofwel 1x2 voor niet eerst of 2x4 voor 1st geplaatste (bijvoorbeeld). Ik heb de rangorde al ingesteld, dus ik kan die gebruiken om maten in specifieke cellen voor elke afbeelding te maken (dwz gebruik een IF-instructie, dus IF RANK is de 1e breedte van de grootte is 2). Mijn VBA is echter vrij zwak.

In principe wil ik - bij het bijwerken van het blad - naar de cellen van de afbeeldingsgrootte kijken en elke afbeeldingsgrootte instellen op het specifieke resultaat van de cellen van de afbeeldingsgrootte. Ik kan in de VBA hierboven niet zien hoe dat precies werkt, maar ik denk dat het gemakkelijk moet zijn!
Deze opmerking is gemaakt door de moderator op de site
Hallo Crystal,

Ik zou u willen vragen of er een manier is om kleur (rode cel = rode vorm) en naam uit specifieke cellen te selecteren. zou het ook mogelijk zijn om automatisch formulieren te maken vanuit VBA?

Bij voorbaad dank :)

Carol
Deze opmerking is gemaakt door de moderator op de site
Hallo Crystal
wat als om de zijde van de kubus, driehoek, doos te bepalen die moet worden bepaald op basis van de lengte, breedte? Help me alstublieft

Dank je
voorzitter
Deze opmerking is gemaakt door de moderator op de site
Hallo Chairil,
Sorry kan je daar nog niet mee helpen. Bedankt voor je reactie.
Deze opmerking is gemaakt door de moderator op de site
is er een manier om dit te laten werken als de cel die je gebruikt om de grootte in te stellen het resultaat is van een formule in plaats van alleen een statische waarde die je handmatig invoert?
Deze opmerking is gemaakt door de moderator op de site
Hallo mathnz, De onderstaande VBA-code kan u helpen het probleem op te lossen. U hoeft alleen de waardecellen en de vormnamen in de code te wijzigen op basis van uw eigen gegevens.
Privé subwerkblad_Calculate()
'Bijgewerkt door' Extendoffice 20211105
On Error Resume Next
Bel SizeCircle("Ovaal 1", Val(Bereik("A1").Waarde)) 'A1 is de waardecel, Ovaal 1 is de vormnaam
Bel SizeCircle ("Smiley Face 2", Val (Bereik ("A2"). Waarde))
Bel SizeCircle ("Hart 3", Val (Bereik ("A3"). Waarde))

End Sub
Particulier subwerkblad_Wijziging (ByVal-doel als bereik)
Dim xAdres als string
On Error Resume Next
Als Target.CountLarge = 1 Dan
xAdres = Doel.Adres (0, 0)
Als xAdres = "A1" Dan
Call SizeCircle("Ovaal 1", Val(Target.Value))
ElseIf xAddress = "A2" Dan
Bel SizeCircle("Smiley Face 2", Val(Target.Value))
ElseIf xAddress = "A3" Dan
Bel SizeCircle("Hart 3", Val(Target.Value))

End If
End If
End Sub

Submaatcirkel (naam als string, diameter)
Dim xCenterX als single
Dim xCenterY als single
Dim xCirkel als vorm
Dim xDiameter als enkel
Bij fout GoTo ExitSub
xDiameter = Diameter
Als xDiameter > 10 Dan is xDiameter = 10
Als xDiameter < 1 Dan xDiameter = 1
Stel xCircle = ActiveSheet.Shapes (Naam) in
Met xCircle
xCenterX = .Links + (.Breedte / 2)
xCenterY = .Boven + (.Hoogte / 2)
.Breedte = Application.CentimetersToPoints(xDiameter)
.Hoogte = Toepassing.CentimetersToPoints(xDiameter)
.Links = xCenterX - (.Breedte / 2)
.Boven = xCenterY - (.Hoogte / 2)
Eindigt met
ExitSub:
End Sub

Er zijn nog geen reacties geplaatst

Volg ons

Copyright © 2009 - www.extendoffice.com. | Alle rechten voorbehouden. Aangedreven door ExtendOffice. | Sitemap
Microsoft en het Office-logo zijn handelsmerken of gedeponeerde handelsmerken van Microsoft Corporation in de Verenigde Staten en / of andere landen.
Beschermd door Sectigo SSL