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

Kako samodejno spremeniti velikost oblike glede na določeno vrednost celice v Excelu?

Če želite samodejno spremeniti velikost oblike glede na vrednost določene celice, vam lahko pomaga ta članek.

Samodejno spremeni velikost oblike na podlagi določene vrednosti celice s kodo VBA


Samodejno spremeni velikost oblike na podlagi določene vrednosti celice s kodo VBA

Naslednja koda VBA vam lahko pomaga spremeniti določeno velikost oblike glede na določeno vrednost celice na trenutnem delovnem listu. Naredite naslednje.

1. Z desno miškino tipko kliknite jeziček lista z obliko, ki jo želite spremeniti, in nato kliknite Ogled kode v meniju z desnim klikom.

2. V Ljubljani Microsoft Visual Basic za aplikacije okno, kopirajte in prilepite naslednjo kodo VBA v okno Code.

Koda VBA: Samodejno spremeni velikost oblike na podlagi določene vrednosti celice v Excelu

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

Opombe: V kodi je »Ovalni 2"Je ime oblike, spremenili boste njegovo velikost. In Vrstica = 2, Stolpec = 1 pomeni, da bo velikost oblike “Oval 2” spremenjena z vrednostjo v A2. Prosimo, spremenite jih po potrebi.

Za samodejno spreminjanje velikosti več oblik na podlagi različnih vrednosti celic uporabite spodnjo kodo VBA.

Koda VBA: Samodejno prilagodi velikost več oblik na podlagi vrednosti določenih celic v Excelu

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

Opombe:

1) V kodi jeOvalni 1""Smeška 3"In"Srce 3"So imena oblik, ki jih boste samodejno spremenili. In A1, A2 inA3 so celice, na podlagi katerih vrednosti boste samodejno spreminjali velikost oblik.
2) Če želite dodati več oblik, dodajte črte "ElseIf xAddress = "A3" Potem"in "Klic velikosti klica (" Srce 2 ", Val (Target.Value))"nad prvim"Konec Če"v kodo. In spremenite naslov celice in ime oblike glede na vaše potrebe.

3. Pritisnite druga + Q tipke hkrati, da zaprete tipko Microsoft Visual Basic za aplikacije okno.

Od zdaj naprej, ko spremenite vrednost v celici A2, se velikost oblike Oval 2 samodejno spremeni. Oglejte si posnetek zaslona:

Ali pa spremenite vrednosti v celicah A1, A2 in A3, da samodejno spremenite velikost ustreznih oblik "Oval 1", "Smiley Face 3" in "Heart 3". Oglejte si posnetek zaslona:

Opombe: Velikost oblike se ne bo več spreminjala, ko bo vrednost celice večja od 10.


Seznam in izvoz vseh oblik v trenutnem Excelovem delovnem zvezku:

O Izvozi grafiko uporabnost Kutools za Excel vam pomaga hitro našteti vse oblike v trenutnem delovnem zvezku in jih lahko vse hkrati izvozite v določeno mapo, kot je prikazano na spodnjem posnetku zaslona shwon. Prenesite in preizkusite zdaj! (30-dnevna prosta pot)


Sorodni članki:


Najboljša orodja za pisarniško produktivnost

Kutools za Excel rešuje večino vaših težav in poveča vašo produktivnost za 80%

  • Ponovna uporaba: Hitro vstavite zapletene formule, grafikoni in vse, kar ste že uporabljali; Šifriraj celice z geslom; Ustvari poštni seznam in pošiljanje e-pošte ...
  • Vrstica Super Formula (enostavno urejanje več vrstic besedila in formule); Bralna postavitev (enostavno branje in urejanje velikega števila celic); Prilepite v filtrirani obseg...
  • Združi celice / vrstice / stolpce brez izgube podatkov; Vsebina razdeljenih celic; Združi podvojene vrstice / stolpce... prepreči podvojene celice; Primerjaj obsege...
  • Izberite Duplicate ali Unique Vrstice; Izberite prazne vrstice (vse celice so prazne); Super Find in Fuzzy Find v mnogih delovnih zvezkih; Naključna izbira ...
  • Natančna kopija Več celic brez spreminjanja sklica formule; Samodejno ustvarjanje referenc na več listov; Vstavi oznake, Potrditvena polja in še več ...
  • Izvleček besedila, Dodaj besedilo, Odstrani po položaju, Odstrani presledek; Ustvari in natisni vmesne seštevke strani Pretvarjanje med vsebino celic in komentarji...
  • Super filter (shranite in uporabite sheme filtrov za druge liste); Napredno razvrščanje glede na mesec / teden / dan, pogostost in drugo; Poseben filter s krepko, ležeče ...
  • Združite delovne zvezke in delovne liste; Spoji tabele na podlagi ključnih stolpcev; Razdelite podatke na več listov; Paketna pretvorba xls, xlsx in PDF...
  • Več kot 300 zmogljivih funkcij. Podpira Office / Excel 2007-2021 in 365. Podpira vse jezike. Enostavna uvedba v vašem podjetju ali organizaciji. 30-dnevna brezplačna preizkusna različica vseh funkcij. 60-dnevna garancija vračila denarja.
zavihek kte 201905

Kartica Office prinaša vmesnik z zavihki v Office in poenostavi vaše delo

  • Omogočite urejanje in branje z zavihki v Wordu, Excelu, PowerPointu, Publisher, Access, Visio in Project.
  • Odprite in ustvarite več dokumentov v novih zavihkih istega okna in ne v novih oknih.
  • Poveča vašo produktivnost za 50%in vsak dan zmanjša na stotine klikov miške za vas!
dno pisarniške mize
Komentarji (16)
Ocene še ni. Bodite prvi in ​​ocenite!
Ta komentar je moderator na spletnem mestu minimiziral
Kako bi to izvedli z več oblikami, odvisno od različnih celic?
Ta komentar je moderator na spletnem mestu minimiziral
Draga Jade,
Članek je posodobljen z novim razdelkom kode, ki vam lahko pomaga izvajati z več oblikami, odvisno od različnih celic. Hvala za vaš komentar.

S spoštovanjem,
Crystal
Ta komentar je moderator na spletnem mestu minimiziral
Kako poimenujem svojo obliko? Kako v zgornjem primeru dodelite ime Oval 2 krogu, ki ste ga narisali?
Ta komentar je moderator na spletnem mestu minimiziral
Dragi Ranjit,
Za poimenovanje oblike izberite to obliko, vnesite ime oblike v polje z imenom in nato pritisnite tipko Enter. Glej prikazano spodnjo sliko.
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, kako lahko ponovim isto za več oblik, povezanih z več celicami v istem modulu?
Ta komentar je moderator na spletnem mestu minimiziral
Spoštovana Abhinaya,
Članek je posodobljen z novim razdelkom kode, ki vam lahko pomaga izvajati z več oblikami, odvisno od različnih celic. Hvala za vaš komentar.

S spoštovanjem,
Crystal
Ta komentar je moderator na spletnem mestu minimiziral
Hi,
Poskušal sem uporabiti vašo objavo za pisanje lastne kode VBA, vendar se zdi, da ne pridem daleč. Predvsem zato, ker ne razumem prav VBA in poskušam samo prilagoditi tvojega. Zanimalo me je, če lahko pomagate. Želim spremeniti dolžino pravokotnika glede na vrednost v celici. Rad bi, da širina pravokotnika ostane enaka, dolžina pa se spremeni. Rad bi, da obe levi oglišči ostaneta na istem mestu in da se podaljša v desno. Je to možno?
Hvala
Ta komentar je moderator na spletnem mestu minimiziral
Dragi lan,
Upamo, da bo naslednja koda VBA rešila vašo težavo. (Prosimo, zamenjajte Oval 1 s svojim imenom oblike)

Zasebni poddelovni list_Spremeni (ByVal Target As Range)
On Error Resume Next
Če je Target.Row = 2 In Target. Column = 1 Potem
Call SizeCircle("Oval 1", Val(Target.Value))
Konec Če
End Sub
Sub SizeCircle (ime kot niz, premer)
Dim xCircle kot oblika
Dim xDiameter kot posamezen
Ob napaki Pojdite na ExitSub
xPremer = premer
Če je xDiameter > 10, potem je xDiameter = 10
Če je xDiameter < 1, potem je xDiameter = 1
Nastavi xCircle = ActiveSheet.Shapes(Ime)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Z xCircle
.LockAspectRatio = msoFalse
.Width = Application.CentimetersToPoints(xDiameter)
Končaj s
ExitSub:
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, ali obstaja način, da se oblika razširi na dve dimenziji (namesto da povečam velikost oblike za 5, jo povečam za 5 na vodoravni in 3 na navpični)?
Ta komentar je moderator na spletnem mestu minimiziral
Dragi Sam,
Naslednji skript VBA vam lahko pomaga rešiti težavo. In dve dimenziji sta celici A1 in B1.

Zasebni poddelovni list_Spremeni (ByVal Target As Range)
On Error Resume Next
Če je Target.Count = 1 Potem
Če se ne seka(Cilj, obseg("A1:B1")) potem ni nič
Call SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
Konec Če
Konec Če
End Sub
Sub SizeCircle (Ime kot niz, Arr kot različica)
Dim I As Long
Dim xCenterX kot samski
Dim xCenterY kot samski
Dim xCircle kot oblika
Ob napaki Pojdite na ExitSub
Za I = 0 do UBound(Arr)
Če je Arr(I) > 10 Potem
Arr(I) = 10
Drugače Če Arr(I) < 1 Potem
Arr(I) = 1
Konec Če
Naslednji
Nastavi xCircle = ActiveSheet.Shapes(Ime)
Z xCircle
xCenterX = .Levo + (.Širina / 2)
xCenterY = .Top + (.Height / 2)
.Width = Application.CentimetersToPoints(Arr(0))
.Višina = Application.CentimetersToPoints(Arr(1))
.Levo = xCenterX - (.Širina / 2)
.Zgornji = xCenterY - (.Višina / 2)
Končaj s
ExitSub:
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Ali obstaja način za to s slikami? Zdi se, da nimam sreče z uporabo kode, kot je bila objavljena.

5 slik na lestvici najboljših, želim, da so slike v 1. ali vezane za 1. večje. Zato imam 2 fiksni velikosti slik, bodisi 1x2 za neprva ali 2x4 za 1. uvrščeno (na primer). Razvrščanje imam že nastavljeno, zato ga lahko uporabim za ustvarjanje velikosti v določenih celicah za vsako sliko (tj. uporabite stavek IF, tako da je IF RANK širina 1. velikosti 2). Moj VBA pa je precej šibek.

V bistvu želim – ob posodobitvi lista – pogledati celice velikosti slike in nastaviti vsako velikost slike na rezultat celic z določeno velikostjo slike. V VBA zgoraj ne vidim, kako to točno deluje, vendar mislim, da bi moralo biti enostavno!
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Crytal,

Rad bi vas vprašal, ali obstaja način za izbiro barve (rdeča celica = rdeča oblika) in imena iz določenih celic. ali bi bilo mogoče tudi samodejno ustvariti obrazce iz VBA?

Najlepša hvala vnaprej :)

Carol
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Crytal
kaj če določiti stran kocke, trikotnika, škatle, ki jo je treba določiti glede na dolžino, širino? Prosim pomagaj mi

Hvala
stol
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Chairil,
Žal ti pri tem še ne morem pomagati. Hvala za vaš komentar.
Ta komentar je moderator na spletnem mestu minimiziral
Ali obstaja način, da to deluje, če je celica, ki jo uporabljate za nastavitev velikosti, rezultat formule in ne le statične vrednosti, ki jo vnesete ročno?
Ta komentar je moderator na spletnem mestu minimiziral
Živjo mathnz, spodnja koda VBA vam lahko pomaga rešiti težavo. Samo spremeniti morate celice vrednosti in imena oblik v kodi na podlagi lastnih podatkov.
Zasebni pod delovni list_Izračunaj()
'Posodobil Extendoffice 20211105
On Error Resume Next
Call SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 je vrednostna celica, Oval 1 je ime oblike
Call SizeCircle("Smiley Face 2", Val(Range("A2").Value))
Call SizeCircle("Heart 3", Val(Range("A3").Value))

End Sub
Zasebni poddelovni list_Spremeni (ByVal Target As Range)
Dim xAddress kot niz
On Error Resume Next
Če je Target.CountLarge = 1 Potem
xAddress = Target.Address(0, 0)
Če je xAddress = "A1" Potem
Call SizeCircle("Oval 1", Val(Target.Value))
ElseIf xAddress = "A2" Potem
Call SizeCircle("Smiley Face 2", Val(Target.Value))
ElseIf xAddress = "A3" Potem
Call SizeCircle("Srce 3", Val(Target.Value))

Konec Če
Konec Če
End Sub

Sub SizeCircle (ime kot niz, premer)
Dim xCenterX kot samski
Dim xCenterY kot samski
Dim xCircle kot oblika
Dim xDiameter kot posamezen
Ob napaki Pojdite na ExitSub
xPremer = premer
Če je xDiameter > 10, potem je xDiameter = 10
Če je xDiameter < 1, potem je xDiameter = 1
Nastavi xCircle = ActiveSheet.Shapes(Ime)
Z xCircle
xCenterX = .Levo + (.Širina / 2)
xCenterY = .Top + (.Height / 2)
.Width = Application.CentimetersToPoints(xDiameter)
.Višina = Application.CentimetersToPoints(xDiameter)
.Levo = xCenterX - (.Širina / 2)
.Zgornji = xCenterY - (.Višina / 2)
Končaj s
ExitSub:
End Sub

Tu še ni objavljenih komentarjev

Sledi nam

Copyright © 2009 - www.extendoffice.com. | Vse pravice pridržane. Poganja ga ExtendOffice. | Kazalo
Microsoft in logotip Office sta blagovni znamki ali registrirani blagovni znamki družbe Microsoft Corporation v ZDA in / ali drugih državah.
Zaščiteno s Sectigo SSL