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

Hogyan lehet automatikusan megváltoztatni az alak méretét az Excel meghatározott cellájának értékétől függően?

Ha automatikusan meg akarja változtatni az alak méretét egy megadott cella értéke alapján, akkor ez a cikk segítségére lehet.

Az alak méretének automatikus módosítása a megadott cellaérték alapján, VBA kóddal


Az alak méretének automatikus módosítása a megadott cellaérték alapján, VBA kóddal

A következő VBA-kód segíthet egy adott alakméret megváltoztatásában az aktuális munkalap megadott cellája alapján. Kérjük, tegye a következőket.

1. Kattintson a jobb gombbal a méretre változtatni kívánt lapfülre, majd kattintson a gombra Kód megtekintése a jobb egérgombbal kattintva.

2. Ban,-ben Microsoft Visual Basic for Applications ablakba másolja és illessze be a következő VBA kódot a Kód ablakba.

VBA-kód: Az alak méretének automatikus módosítása az Excel megadott cellája alapján

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

Megjegyzések: A kódban:2. ovális”Az alak neve, amelynek méretét megváltoztatja. És Sor = 2, Oszlop = 1 azt jelenti, hogy az „Oval 2” alak mérete megváltozik az A2 értékével. Kérjük, változtassa meg őket szükség szerint.

Több alakzat automatikus átméretezéséhez különböző cellaértékek alapján alkalmazza az alábbi VBA kódot.

VBA-kód: Több alakzat automatikus átméretezése az Excel különböző, megadott cellái értéke alapján

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

Megjegyzések:

1) A kódban:1. ovális","Mosolygó arc 3"És"Szív 3”Az alakzatok neve, amelyek méretét automatikusan megváltoztatja. És A1, A2 és aA3 azok a cellák, amelyek értéke alapján automatikusan átméretezi az alakzatokat.
2) Ha további alakzatokat szeretne hozzáadni, kérjük, adjon hozzá vonalakat "ElseIf xAddress = "A3" Akkor"és "Hívás SizeCircle (" Szív 2 ", Val (Target.Value))"az első felett"Ha véget"sor a kódban. És változtassa meg a cella címét és az alakzat nevét az Ön igényei szerint.

3. nyomja meg más + Q gombok egyszerre a Microsoft Visual Basic for Applications ablak.

Mostantól, amikor megváltoztatja az értéket az A2 cellában, az Oval 2 alakzat mérete automatikusan megváltozik. Lásd a képernyőképet:

Vagy módosítsa az A1, A2 és A3 cellák értékeit, hogy automatikusan átméretezze a megfelelő "Oval 1", "Smiley Face 3" és "Heart 3" alakokat. Lásd a képernyőképet:

Megjegyzések: Az alak mérete már nem változik, ha a cella értéke nagyobb, mint 10.


Az összes alakzat felsorolása és exportálása az aktuális Excel munkafüzetben:

A Exportálja a grafikát hasznossága Kutools az Excel számára segít gyorsan felsorolni az összes alakzatot az aktuális munkafüzetben, és mindet egyszerre exportálhatja egy adott mappába, az alábbi képernyőképként. Töltse le és próbálja ki most! (30-napos ingyenes túra)


Kapcsolódó cikkek:


A legjobb irodai termelékenységi eszközök

A Kutools for Excel megoldja a legtöbb problémát, és 80% -kal növeli a termelékenységet

  • újrafelhasználás: Gyorsan helyezze be összetett képletek, diagramok és bármi, amit korábban használt; Cellák titkosítása jelszóval; Levelezőlista létrehozása és e-maileket küldeni ...
  • Szuper Formula Bár (könnyedén szerkeszthet több szöveget és képletet); Olvasás elrendezés (könnyen olvasható és szerkeszthető nagyszámú cella); Beillesztés a Szűrt tartományba...
  • Cellák / sorok / oszlopok egyesítése az adatok elvesztése nélkül; Osztott cellák tartalma; Kombinálja a duplikált sorokat / oszlopokat... megakadályozza az ismétlődő cellákat; Hasonlítsa össze a tartományokat...
  • Válassza a Másolat vagy az Egyedi lehetőséget Sorok; Válassza az Üres sorok lehetőséget (az összes cella üres); Super Find és Fuzzy Find sok munkafüzetben; Véletlenszerű kiválasztás ...
  • Pontos másolás Több cella a képletreferencia megváltoztatása nélkül; Automatikus referenciák létrehozása több lapra; Helyezze be a golyókat, Jelölőnégyzetek és még sok más ...
  • Kivonat szöveg, Szöveg hozzáadása, Eltávolítás pozíció szerint, Hely eltávolítása; Hozz létre és nyomtasson személyhívó részösszegeket; Konvertálás a cellatartalom és a megjegyzések között...
  • Szuper szűrő (mentse el és alkalmazza a szűrősémákat más lapokra); Haladó rendezés hónap / hét / nap, gyakoriság és egyebek szerint; Speciális szűrő félkövér, dőlt betűvel ...
  • Kombinálja a munkafüzeteket és a munkalapokat; Táblázatok egyesítése kulcsoszlopok alapján; Az adatok felosztása több lapra; Kötegelt konvertálás xls, xlsx és PDF...
  • Több mint 300 hatékony funkció. Támogatja az Office / Excel 2007-2021 és 365 verziókat. Minden nyelvet támogat. Könnyű üzembe helyezés vállalatában vagy szervezetében. Teljes funkciók 30 napos ingyenes próbaverzió. 60 napos pénzvisszafizetési garancia.
kte lap 201905

Az Office fül a füles felületet hozza az Office-ba, és sokkal könnyebbé teszi a munkáját

  • Füles szerkesztés és olvasás engedélyezése Wordben, Excelben és PowerPointban, Publisher, Access, Visio és Project.
  • Több dokumentum megnyitása és létrehozása ugyanazon ablak új lapjain, mint új ablakokban.
  • 50% -kal növeli a termelékenységet, és naponta több száz kattintással csökkenti az egér kattintását!
officetab alja
A megjegyzések rendezése szerint
Hozzászólások (16)
Még nincs értékelés. Legyen Ön az első, aki értékel!
A weboldal moderátora ezt a megjegyzést minimalizálta
Hogyan hajtanád végre ezt több alakzattal, mindegyik különböző cellától függően?
A weboldal moderátora ezt a megjegyzést minimalizálta
Kedves Jade!
A cikk egy új kódrésszel frissül, amely segíthet több alakzattal végrehajtani, mindegyik különböző cellától függően. Köszönjük észrevételét.

Üdvözlettel,
Kristály
A weboldal moderátora ezt a megjegyzést minimalizálta
Hogyan nevezzem el az alakomat? A fenti példában hogyan rendelheti hozzá az Ovális 2 nevet a megrajzolt körhöz?
A weboldal moderátora ezt a megjegyzést minimalizálta
Kedves Ranjit!
Egy alakzat elnevezéséhez válassza ki ezt az alakzatot, írja be az alakzat nevét a Név mezőbe, majd nyomja meg az Enter billentyűt. Lásd az alábbi képet.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia! Hogyan replikálhatom ugyanazt több alakzathoz, amelyek több cellához vannak kapcsolva ugyanabban a modulban?
A weboldal moderátora ezt a megjegyzést minimalizálta
Kedves Abhinaya!
A cikk egy új kódrésszel frissül, amely segíthet több alakzattal végrehajtani, mindegyik különböző cellától függően. Köszönjük észrevételét.

Üdvözlettel,
Kristály
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia,
Megpróbáltam a bejegyzésedet felhasználni saját VBA-kódom megírására, de úgy tűnik, nem jutok messzire. Főleg azért, mert nem igazán értek a VBA-hoz, és csak próbálom adaptálni a tiédet. Kíváncsi voltam, tudtok-e segíteni. Meg akarom változtatni egy téglalap hosszát a cellában lévő érték függvényében. Szeretném, ha a téglalap szélessége változatlan maradna, de a hossza változna. Szeretném, ha mindkét bal oldali csúcs ugyanazon a helyen maradna, és jobbra hosszabbodna. Van erre lehetőség?
Köszönöm
A weboldal moderátora ezt a megjegyzést minimalizálta
Kedves Lan!
Reméljük, hogy a következő VBA-kód megoldja a problémát. (Kérjük, cserélje ki az Oval 1-et a saját alakjának nevére)

Private Sub Worksheet_Change (ByVal Target mint Range)
On Error Resume Next
Ha Cél.Sor = 2 és Cél.Oszlop = 1 Akkor
Call SizeCircle("Ovális 1", Val(Cél.Érték))
Ha véget
End Sub
AlméretCircle (név karakterláncként, átmérő)
Dim xCircle As Shape
Dim xDiameter As Single
Hiba esetén GoTo ExitSub
xDiameter = Átmérő
Ha xÁtmérő > 10 Akkor xÁtmérő = 10
Ha xÁtmérő < 1, akkor xÁtmérő = 1
xCircle beállítása = ActiveSheet.Shapes(Név)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Az xCircle segítségével
.LockAspectRatio = msoFalse
.Width = Alkalmazás.CentimetersToPoints(xDiameter)
Vége
ExitSub:
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Sziasztok, van rá mód, hogy az alakzatot két dimenzióban bővítsem (ahelyett, hogy 5-tel növelném a formát, vízszintesen 5-tel, függőlegesen 3-mal)?
A weboldal moderátora ezt a megjegyzést minimalizálta
Kedves Sam!
A következő VBA-szkript segíthet a probléma megoldásában. És a két dimenzió az A1 és a B1 cella.

Private Sub Worksheet_Change (ByVal Target mint Range)
On Error Resume Next
Ha Target.Count = 1 Akkor
Ha nem metszik(cél, tartomány("A1:B1")) akkor semmi
Hívja a SizeCircle("Oval 2", Array(Val(Tartomány("A1").Érték), Val(Tartomány("B1").Érték)))
Ha véget
Ha véget
End Sub
Sub SizeCircle (név mint karakterlánc, Arr mint változat)
Dim I As Long
Dim xCenterX As Single
Dim xCenterY As Single
Dim xCircle As Shape
Hiba esetén GoTo ExitSub
Ha I = 0 - UBound(Arr)
Ha Arr(I) > 10 Akkor
Arr(I) = 10
ElseIf Arr(I) < 1 Akkor
Arr(I) = 1
Ha véget
Következő
xCircle beállítása = ActiveSheet.Shapes(Név)
Az xCircle segítségével
xCenterX = .Bal + (.Szélesség / 2)
xCenterY = .Felső + (.Magasság / 2)
.Width = Alkalmazás.CentimetersToPoints(Arr(0))
.Magasság = Alkalmazás.CentimetersToPoints(Arr(1))
.Bal = xCenterX - (.Szélesség / 2)
.Top = xCenterY - (.Magasság / 2)
Vége
ExitSub:
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Meg lehet ezt csinálni a Képek segítségével? Úgy tűnik, nincs szerencsém a közzétett kód használatához.

5 kép a ranglistán, azt szeretném, ha az 1. vagy az 1. holtversenyben lévő képek nagyobbak lennének. Ezért van 2 rögzített képméretem, vagy 1x2 a nem első helyezettnek vagy 2x4 az első helyezettnek (például). Már beállítottam a rangsorolást, így használhatom a méretek létrehozására minden egyes képhez adott cellában (vagyis használjon IF utasítást, így az IF RANK az 1. méret szélessége 1). A VBA-m viszont elég gyenge.

Alapvetően azt szeretném, hogy - lapon frissítve - megnézzem a képméret cellákat, és minden képméretet az adott képméret cella eredményéhez állítsam be. A fenti VBA-ban nem látom, hogy ez pontosan hogyan működik, de szerintem egyszerűnek kell lennie!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Crytal!

Azt szeretném kérdezni, hogy van-e mód a szín (vörös cella = piros forma) és a név kiválasztására adott cellákból. VBA-ból is lehetne automatikusan nyomtatványokat létrehozni?

Előre is nagyon köszönöm :)

Ének
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Crytal
mi van, ha meghatározzuk a kocka, háromszög, doboz oldalát, amelyet a hosszúság, szélesség alapján kell meghatározni? Kérlek segíts

Köszönöm
chairil
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Chairil!
Sajnos ebben még nem tudok segíteni. Köszönöm a hozzászólásod.
A weboldal moderátora ezt a megjegyzést minimalizálta
van erre mód, ha a méret beállításához használt cella egy képlet eredménye, nem pedig pusztán egy kézzel megadott statikus érték?
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia mathnz! Az alábbi VBA kód segíthet a probléma megoldásában. Csak meg kell változtatnia az értékcellákat és az alakzatneveket a kódban a saját adatai alapján.
Privát almunkalap_Calculate()
'Frissítette Extendoffice 20211105
On Error Resume Next
Call SizeCircle("Ovális 1", Val(Tartomány("A1").Érték)) „A1 az értékcella, az ovális 1 az alakzat neve
Call SizeCircle("Smiley Face 2", Val(Tartomány("A2").Érték))
Call SizeCircle("szív 3", Val(Tartomány("A3").Érték))

End Sub
Private Sub Worksheet_Change (ByVal Target mint Range)
Dim xAddress As String
On Error Resume Next
Ha Target.CountLarge = 1 Akkor
xAddress = Cél.Cím(0, 0)
Ha xAddress = "A1" Akkor
Call SizeCircle("Ovális 1", Val(Cél.Érték))
ElseIf xAddress = "A2" Akkor
Call SizeCircle("Smiley Face 2", Val(Target.Value))
ElseIf xAddress = "A3" Akkor
Call SizeCircle("Heart 3", Val(Target. Value))

Ha véget
Ha véget
End Sub

AlméretCircle (név karakterláncként, átmérő)
Dim xCenterX As Single
Dim xCenterY As Single
Dim xCircle As Shape
Dim xDiameter As Single
Hiba esetén GoTo ExitSub
xDiameter = Átmérő
Ha xÁtmérő > 10 Akkor xÁtmérő = 10
Ha xÁtmérő < 1, akkor xÁtmérő = 1
xCircle beállítása = ActiveSheet.Shapes(Név)
Az xCircle segítségével
xCenterX = .Bal + (.Szélesség / 2)
xCenterY = .Felső + (.Magasság / 2)
.Width = Alkalmazás.CentimetersToPoints(xDiameter)
.Magasság = Alkalmazás.CentimetersToPoints(xDiameter)
.Bal = xCenterX - (.Szélesség / 2)
.Top = xCenterY - (.Magasság / 2)
Vége
ExitSub:
End Sub

Még senki sem írt megjegyzést
Hagyja meg észrevételeit
Feladás vendégként
×
Értékeld ezt a bejegyzést:
0   Karakterek
Javasolt helyek

Kövess minket

Copyright © 2009 - www.extendoffice.com. | Minden jog fenntartva. Powered by ExtendOffice. | Oldaltérkép
A Microsoft és az Office logó a Microsoft Corporation védjegyei vagy bejegyzett védjegyei az Egyesült Államokban és / vagy más országokban.
Sectigo SSL védi