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

Hvordan ændres formformat automatisk / afhængig af specificeret celleværdi i Excel?

Hvis du automatisk vil ændre formstørrelsen baseret på værdien af ​​en bestemt celle, kan denne artikel hjælpe dig.

Skift formformat automatisk baseret på specificeret celleværdi med VBA-kode


Skift formformat automatisk baseret på specificeret celleværdi med VBA-kode

Den følgende VBA-kode kan hjælpe dig med at ændre en bestemt formstørrelse baseret på den angivne celleværdi i det aktuelle regneark. Gør som følger.

1. Højreklik på arkfanen med den form, du har brug for for at ændre størrelse, og klik derefter på Vis kode fra højreklikmenuen.

2. i Microsoft Visual Basic til applikationer vindue, kopier og indsæt følgende VBA-kode i vinduet Kode.

VBA-kode: Skift automatisk formstørrelse baseret på den angivne celleværdi 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

Bemærk: I koden, “Oval 2”Er det formnavn, du vil ændre størrelsen. Og Række = 2, Kolonne = 1 betyder, at størrelsen på formen ”Oval 2” ændres med værdien i A2. Skift dem, som du har brug for.

For automatisk ændring af størrelsen på flere figurer baseret på forskellige celleværdier, skal du anvende nedenstående VBA-kode.

VBA-kode: Ændr størrelsen på flere figurer automatisk baseret på forskellige specificerede cellers værdi 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

Bemærkninger:

1) I koden, “Oval 1","Smiley 3"Og"Heart 3”Er figurernes navn. Du vil ændre deres størrelse automatisk. Og A1, A2 ogA3 er cellerne, hvilke værdier du automatisk ændrer størrelsen på figurer baseret på.
2) Hvis du vil tilføje flere figurer, skal du tilføje linjer "ElseIf xAddress = "A3" Derefter"og "Call SizeCircle (" Heart 2 ", Val (Target.Value))"over den første"End If"linje i koden. Og skift celle-adresse og formnavn ud fra dine behov.

3. Trykke andre + Q taster samtidigt for at lukke Microsoft Visual Basic til applikationer vindue.

Fra nu af, når du ændrer værdien i celle A2, ændres størrelsen på form Oval 2 automatisk. Se skærmbillede:

Eller skift værdierne i celle A1, A2 og A3 for automatisk at ændre størrelsen på de tilsvarende figurer "Oval 1", "Smiley Face 3" og "Heart 3". Se skærmbillede:

Bemærk: Formstørrelsen ændres ikke længere, når celleværdien er større end 10.


Liste over og eksport af alle figurer i den aktuelle Excel-projektmappe:

Eksporter grafik nytte af Kutools til Excel hjælpe dig med hurtigt at liste alle figurer i den aktuelle projektmappe, og du kan eksportere dem alle til en bestemt mappe på én gang som nedenstående skærmbillede shwon. Download og prøv det nu! (30-dag gratis spor)


Relaterede artikler:


De bedste Office-produktivitetsværktøjer

Kutools til Excel løser de fleste af dine problemer og øger din produktivitet med 80%

  • Genbruge: Indsæt hurtigt komplekse formler, diagrammer og alt, hvad du har brugt før; Krypter celler med adgangskode Opret postliste og send e-mails ...
  • Super formel bar (let redigere flere linjer med tekst og formel); Læsning Layout (let at læse og redigere et stort antal celler); Indsæt til filtreret rækkevidde...
  • Flet celler / rækker / kolonner uden at miste data; Split celler indhold; Kombiner duplikerede rækker / kolonner... Forhindre duplikerede celler; Sammenlign områder...
  • Vælg Duplicate eller Unique Rækker; Vælg tomme rækker (alle celler er tomme); Super Find og Fuzzy Find i mange arbejdsbøger; Tilfældig valg ...
  • Præcis kopi Flere celler uden at ændre formelreference; Auto Opret referencer til flere ark; Indsæt kugler, Afkrydsningsfelter og mere ...
  • Uddrag tekst, Tilføj tekst, Fjern efter position, Fjern mellemrum; Opret og udskriv personsøgningssubtotaler; Konverter mellem celler indhold og kommentarer...
  • Superfilter (gem og anvend filterskemaer på andre ark); Avanceret sortering efter måned / uge / dag, hyppighed og mere; Specielt filter af fed, kursiv ...
  • Kombiner arbejdsbøger og arbejdsark; Fletabeller baseret på nøglekolonner; Opdel data i flere ark; Batch Konverter xls, xlsx og PDF...
  • Mere end 300 kraftfulde funktioner. Understøtter Office / Excel 2007-2021 og 365. Understøtter alle sprog. Nem implementering i din virksomhed eller organisation. Fuld funktioner 30-dages gratis prøveperiode. 60 dages pengene tilbage garanti.
kte-fane 201905

Fanen Office bringer en grænseflade til et kontor med Office, og gør dit arbejde meget lettere

  • Aktiver redigering og læsning af faner i Word, Excel, PowerPoint, Publisher, Access, Visio og Project.
  • Åbn og opret flere dokumenter i nye faner i det samme vindue snarere end i nye vinduer.
  • Øger din produktivitet med 50 % og reducerer hundredvis af museklik for dig hver dag!
officetab bund
Sorter kommentarer efter
Kommentarer (16)
Ingen vurderinger endnu. Vær den første til at bedømme!
Denne kommentar blev minimeret af moderatoren på webstedet
Hvordan vil du udføre dette med flere former, hver afhængigt af forskellige celler?
Denne kommentar blev minimeret af moderatoren på webstedet
Kære Jade,
Artiklen er opdateret med en ny kodesektion, som kan hjælpe dig med at udføre med flere former, hver afhængigt af forskellige celler. Tak for din kommentar.

Venlig hilsen,
Krystal
Denne kommentar blev minimeret af moderatoren på webstedet
Hvordan navngiver jeg min form? Hvordan tildeler du i dit eksempel ovenfor navnet Oval 2 til den cirkel, du har tegnet?
Denne kommentar blev minimeret af moderatoren på webstedet
Kære Ranjit,
For at navngive en form skal du vælge denne form, indtaste formnavnet i navnefeltet og derefter trykke på Enter-tasten. Se billedet nedenfor.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, hvordan replikerer jeg det samme for flere former knyttet til flere celler i det samme modul?
Denne kommentar blev minimeret af moderatoren på webstedet
Kære Abhinaya,
Artiklen er opdateret med en ny kodesektion, som kan hjælpe dig med at udføre med flere former, hver afhængigt af forskellige celler. Tak for din kommentar.

Venlig hilsen,
Krystal
Denne kommentar blev minimeret af moderatoren på webstedet
Hej,
Jeg har forsøgt at bruge dit indlæg til at skrive min egen VBA-kode, men det ser ikke ud til at komme ret langt. Hovedsageligt fordi jeg ikke rigtig forstår VBA, og jeg prøver bare at tilpasse din. Jeg tænkte på, om du kunne hjælpe. Jeg ønsker at ændre længden af ​​et rektangel afhængigt af værdien i en celle. Jeg vil gerne have bredden, hvis rektanglet forbliver det samme, men længden ændres. Jeg vil gerne have, at begge venstre håndspidser bliver på samme sted, og at den forlænges til højre. Er dette muligt?
Tak
Denne kommentar blev minimeret af moderatoren på webstedet
Kære lan,
Håber følgende VBA-kode kan løse dit problem. (Erstat venligst Oval 1 med dit eget formnavn)

Privat Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Hvis Target.Row = 2 Og Target.Column = 1 Så
Kald SizeCircle("Oval 1", Val(Target.Value))
End If
End Sub
Sub SizeCircle(navn som streng, diameter)
Dim xCirkel som form
Dim xDiameter Som enkelt
Ved fejl GoTo ExitSub
xDiameter = Diameter
Hvis xDiameter > 10, så er xDiameter = 10
Hvis xDiameter < 1, så er xDiameter = 1
Indstil xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Med xCircle
.LockAspectRatio = msoFalse
.Width = Application.CentimetersToPoints(xDiameter)
Slut med
ExitSub:
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, er der en måde, hvorpå jeg kan få formen til at udvide sig på to dimensioner (i stedet for at øge formstørrelsen med 5, øge den 5 på vandret og 3 på lodret)?
Denne kommentar blev minimeret af moderatoren på webstedet
Kære Sam,
Følgende VBA-script kan hjælpe dig med at løse problemet. Og de to dimensioner er celle A1 og B1.

Privat Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Hvis Target.Count = 1 Så
Hvis ikke skærer (Mål, rækkevidde("A1:B1")) er ingenting så
Kald SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
End If
End If
End Sub
Sub SizeCircle(navn som streng, Arr som variant)
Dim I Så længe
Dim xCenterX Som Single
Dim xCenterY Som Single
Dim xCirkel som form
Ved fejl GoTo ExitSub
For I = 0 Til UBound(Arr)
Hvis Arr(I) > 10 Så
Arr(I) = 10
ElseIf Arr(I) < 1 Then
Arr(I) = 1
End If
Næste
Indstil xCircle = ActiveSheet.Shapes(Name)
Med xCircle
xCenterX = .Left + (.Width / 2)
xCenterY = .Top + (.Højde / 2)
.Width = Application.CentimetersToPoints(Arr(0))
.Højde = Application.CentimetersToPoints(Arr(1))
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.Højde / 2)
Slut med
ExitSub:
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Er der en måde at gøre dette på med billeder? Jeg ser ikke ud til at have held med at bruge koden som postet.

5 billeder på en rangliste, jeg ønsker, at billederne i 1. eller lige for 1. skal være større. Derfor har jeg 2 faste billedstørrelser, enten 1x2 for ikke først eller 2x4 for 1. placeret (f.eks.). Jeg har allerede sat rangordning op, så jeg kan bruge den til at oprette størrelser i specifikke celler for hvert billede (dvs. brug en IF-sætning, så IF RANK er 1. størrelse, bredde er 2). Min VBA er dog ret svag.

Grundlæggende vil jeg - på arkopdatering - se på billedstørrelsesceller og indstille hver billedstørrelse til det specifikke billedstørrelsescelleresultat. Jeg kan ikke se i VBA ovenfor, hvordan det præcist virker, men jeg tror, ​​det burde være nemt!
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Crystal,

Jeg vil gerne spørge dig, om der er en måde at vælge farve (rød celle = rød form) og navn fra specifikke celler. kunne det også lade sig gøre at oprette formularer automatisk fra VBA?

På forhånd mange tak :)

Carol
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Crystal
hvad hvis man bestemmer siden af ​​terningen, trekanten, boksen, der skal bestemmes ud fra længden, bredden? Vær venlig at hjælpe mig

Tak
stolil
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Chairil,
Jeg kan desværre ikke hjælpe dig med det endnu. Tak for din kommentar.
Denne kommentar blev minimeret af moderatoren på webstedet
er der en måde for dette at fungere, hvis den celle, du bruger til at indstille størrelsen, er resultatet af en formel i stedet for blot en statisk værdi, du manuelt indtaster?
Denne kommentar blev minimeret af moderatoren på webstedet
Hej mathnz, VBA-koden nedenfor kan hjælpe dig med at løse problemet. Du skal bare ændre værdicellerne og formnavnene i koden baseret på dine egne data.
Privat underregneark_Beregn()
'Opdateret af Extendoffice 20211105
On Error Resume Next
Kald SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 er værdicellen, Oval 1 er formnavnet
Call SizeCircle("Smiley Face 2", Val(Range("A2").Value))
Kald SizeCircle("Hjerte 3", Val(Range("A3").Value))

End Sub
Privat Sub Worksheet_Change (ByVal Target As Range)
Dim xAddress As String
On Error Resume Next
Hvis Target.CountLarge = 1 Så
xAddress = Target.Address(0, 0)
Hvis xAddress = "A1" Så
Kald SizeCircle("Oval 1", Val(Target.Value))
ElseIf xAddress = "A2" Derefter
Call SizeCircle("Smiley Face 2", Val(Target.Value))
ElseIf xAddress = "A3" Derefter
Kald SizeCircle("Hjerte 3", Val(Target.Value))

End If
End If
End Sub

Sub SizeCircle(navn som streng, diameter)
Dim xCenterX Som Single
Dim xCenterY Som Single
Dim xCirkel som form
Dim xDiameter Som enkelt
Ved fejl GoTo ExitSub
xDiameter = Diameter
Hvis xDiameter > 10, så er xDiameter = 10
Hvis xDiameter < 1, så er xDiameter = 1
Indstil xCircle = ActiveSheet.Shapes(Name)
Med xCircle
xCenterX = .Left + (.Width / 2)
xCenterY = .Top + (.Højde / 2)
.Width = Application.CentimetersToPoints(xDiameter)
.Højde = Application.CentimetersToPoints(xDiameter)
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.Højde / 2)
Slut med
ExitSub:
End Sub

Der er endnu ingen kommentarer her
Efterlad dine kommentarer
Sender som gæst
×
Bedøm dette indlæg:
0   Tegn
Foreslåede steder

Følg os

Copyright © 2009 - www.extendoffice.com. | Alle rettigheder forbeholdes. Drevet af ExtendOffice. | | Sitemap
Microsoft og Office-logoet er varemærker eller registrerede varemærker tilhørende Microsoft Corporation i USA og / eller andre lande.
Beskyttet af Sectigo SSL