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

Ինչպե՞ս ինքնաբերաբար փոխել ձևի չափը `հիմնված / կախված Excel- ում նշված բջջային արժեքից:

Եթե ​​ցանկանում եք ավտոմատ կերպով փոխել ձևի չափը ՝ ելնելով նշված բջիջի արժեքից, այս հոդվածը կարող է օգնել ձեզ:

Ավտոմատ փոխել ձևի չափը ՝ ելնելով նշված բջջային արժեքից, VBA կոդով


Ավտոմատ փոխել ձևի չափը ՝ ելնելով նշված բջջային արժեքից, VBA կոդով

Հաջորդ VBA կոդը կարող է օգնել ձեզ փոխել որոշակի ձևի չափը `ելնելով ընթացիկ աշխատանքային թերթում նշված բջջային արժեքից: Խնդրում եմ, արեք հետևյալ կերպ.

1. Աջ կտտացրեք թերթիկի ներդիրին, որի չափը պետք է փոխեք, և կտտացրեք Դիտել կոդը աջ կտտացնելու ցանկից:

2. Մեջ Microsoft Visual Basic հավելվածների համար պատուհանը, պատճենեք և տեղադրեք հետևյալ VBA կոդը օրենսգրքի պատուհանում:

VBA կոդ. 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

ՆշումԿոդում `«Օվալ 2”Այն ձևի անունն է, որը դուք կփոխեք դրա չափը: Եվ Տող = 2, Սյունակ = 1 նշանակում է, որ «Օվալ 2» ձևի չափը կփոխվի A2- ի արժեքով: Խնդրում ենք փոխել դրանք, ինչպես ձեզ հարկավոր է:

Բջջի տարբեր արժեքների վրա հիմնված բազմաթիվ ձևերի ավտոմատ չափափոխման համար խնդրում ենք կիրառել ստորև նշված VBA կոդը:

VBA կոդ. 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

Նշումներ:

1) ծածկագրում «Օվալ 1","Ileպտերես դեմք 3"Եւ"Heart 3»Ձևերի անունն է, դուք ինքնաբերաբար կփոխեք դրանց չափերը: Եվ A1, A2 ևA3 այն բջիջներն են, որոնց արժեքները, որոնց հիման վրա դուք ինքնաբերաբար կփոխեք ձևերը:
2) Եթե ցանկանում եք ավելացնել ավելի շատ ձևեր, խնդրում ենք ավելացնել տողեր »ElseIf xAddress = "A3" Ապաեւ այլն "Callանգի չափի շրջան (" Սիրտ 2 ", Val (Target.Value))«առաջինից վեր»Վերջ: Եթե"տողում ծածկագրում: Եվ փոխեք բջջային հասցեն և ձևի անունը` ելնելով ձեր կարիքներից:

3. Մամուլ ալտ + Q ստեղները միաժամանակ փակելու համար Microsoft Visual Basic հավելվածների համար պատուհան.

Այսուհետ, երբ A2 բջիջում փոխում եք արժեքը, Օվալ 2 ձևի չափը ավտոմատ կերպով փոխվում է: Տեսեք,

Կամ փոխեք A1, A2 և A3 բջիջների արժեքները `համապատասխանաբար« Օվալ 1 »,« ileպտացող դեմք 3 »և« Սրտ 3 »համապատասխան ձևերը չափափոխելու համար: Տեսեք,

ՆշումՁևի չափը այլևս չի փոխվի, երբ բջջի արժեքը 10-ից մեծ է:


Listուցակեք և արտահանեք բոլոր ձևերը Excel- ի ընթացիկ աշխատանքային գրքում.

The Արտահանել գրաֆիկա օգտակարությունը Excel- ի համար նախատեսված գործիքներ կօգնեն ձեզ արագորեն թվարկել բոլոր ձևերը ընթացիկ աշխատանքային գրքում, և բոլորը կարող եք միանգամից արտահանել որոշակի թղթապանակ, քանի որ ստորև նշված էկրանի նկարը: Ներբեռնեք և փորձեք հիմա: (30- օր անվճար երթուղի)


Առնչվող հոդվածներ քանակը:


Գրասենյակի արտադրողականության լավագույն գործիքները

Excel-ի համար Kutools-ը լուծում է ձեր խնդիրների մեծ մասը և բարձրացնում ձեր արտադրողականությունը 80%-ով

  • Վերաօգտագործել: Արագ տեղադրեք բարդ բանաձևեր, գծապատկերներ և այն ամենը, ինչ դուք նախկինում օգտագործել եք. Ryածկագրել բջիջները գաղտնաբառով; Ստեղծեք փոստային ցուցակ և նամակներ ուղարկել ...
  • Super Formula Bar (հեշտությամբ խմբագրեք տեքստի և բանաձևի բազմաթիվ տողեր); Ընթերցանության դասավորությունը (հեշտությամբ կարդալ և խմբագրել մեծ թվով բջիջներ); Տեղադրել ֆիլտրացված տիրույթում...
  • Միաձուլել բջիջները / տողերը / սյունակները առանց տվյալների կորստի. Պառակտված բջիջների պարունակությունը; Միավորել կրկնօրինակ տողերը / սյունակները... Կանխել կրկնօրինակ բջիջները; Համեմատեք միջակայքերը...
  • Ընտրեք Կրկնօրինակ կամ Եզակի Շարքեր; Ընտրեք դատարկ շարքեր (բոլոր բջիջները դատարկ են); Super Find և Fuzzy Find շատ աշխատանքային գրքույկներում; Պատահական ընտրություն ...
  • Actշգրիտ պատճեն Բազմաթիվ բջիջներ ՝ առանց բանաձևի հղումը փոխելու; Ավտոմատ ստեղծեք հղումներ դեպի մի քանի թերթեր; Տեղադրեք փամփուշտներ, Տուփեր և ավելին ...
  • Քաղվածք տեքստ, Տեքստ ավելացնել, հեռացնել ըստ դիրքի, Հեռացնել տարածությունը; Ստեղծել և տպել էջային ենթագոտիներ; Փոխարկել բջիջների բովանդակության և մեկնաբանությունների միջև...
  • Սուպեր զտիչ (պահպանել և կիրառել ֆիլտրի սխեմաները այլ թերթերի վրա); Ընդլայնված տեսակավորում ըստ ամիս / շաբաթ / օր, հաճախականություն և ավելին; Հատուկ զտիչ համարձակ, շեղատառով ...
  • Միավորել աշխատանքային տետրերը և աշխատանքային թերթերը; Միավորել աղյուսակները ՝ հիմնված հիմնական սյունակների վրա; Տվյալները բաժանեք մի քանի թերթերի; Խմբաքանակի փոխակերպում xls, xlsx և PDF...
  • Ավելի քան 300 հզոր հատկություններ. Աջակցում է Office / Excel 2007-2021 և 365: Աջակցում է բոլոր լեզուներին: Հեշտ տեղակայում ձեր ձեռնարկությունում կամ կազմակերպությունում: Ամբողջական հնարավորություններ 30-օրյա անվճար փորձարկում: 60-օրյա գումարի վերադարձի երաշխիք:
kte էջանիշը 201905

Office Tab- ը Tabbed ինտերֆեյսը բերում է Office, և ձեր աշխատանքը շատ ավելի դյուրին դարձրեք

  • Միացնել ներդիրներով խմբագրումը և ընթերցումը Word, Excel, PowerPoint- ով, Հրատարակիչ, Access, Visio և Project:
  • Բացեք և ստեղծեք բազմաթիվ փաստաթղթեր նույն պատուհանի նոր ներդիրներում, այլ ոչ թե նոր պատուհաններում:
  • Բարձրացնում է ձեր արտադրողականությունը 50%-ով և նվազեցնում մկնիկի հարյուրավոր սեղմումները ձեզ համար ամեն օր:
officetab ներքևում
Տեսակավորել մեկնաբանությունները ըստ
մեկնաբանություններ (16)
Դեռևս գնահատականներ չկան: Եղիր առաջինը, ով կգնահատի:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ինչպե՞ս կկատարեիք սա մի քանի ձևերով, որոնցից յուրաքանչյուրը կախված է տարբեր բջիջներից:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հարգելի Ջեյդ,
Հոդվածը թարմացվում է կոդերի նոր բաժինով, որը կարող է օգնել ձեզ կատարել բազմաթիվ ձևերով, որոնցից յուրաքանչյուրը կախված է տարբեր բջիջներից: Շնորհակալություն մեկնաբանության համար։

Best Regards,
բյուրեղապակի
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ինչպե՞ս անվանել իմ ձևը: Ձեր վերը նշված օրինակում ինչպե՞ս եք վերագրում Ձեր գծած շրջանագծին Օվալ 2 անունը:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հարգելի Ռանջիտ,
Ձևը անվանելու համար խնդրում ենք ընտրել այս ձևը, մուտքագրել ձևի անունը Անունի վանդակում և սեղմել Enter ստեղնը: Տես ստորև ներկայացված պատկերը:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև, ինչպե՞ս կարող եմ նույնը կրկնօրինակել նույն մոդուլի մի քանի բջիջների հետ կապված բազմաթիվ ձևերի համար:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հարգելի Աբհինա,
Հոդվածը թարմացվում է կոդերի նոր բաժինով, որը կարող է օգնել ձեզ կատարել բազմաթիվ ձևերով, որոնցից յուրաքանչյուրը կախված է տարբեր բջիջներից: Շնորհակալություն մեկնաբանության համար։

Best Regards,
բյուրեղապակի
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջու՜յն,
Ես փորձել եմ օգտագործել ձեր գրառումը իմ սեփական VBA կոդը գրելու համար, բայց կարծես թե շատ հեռու չեմ գնում: Հիմնականում այն ​​պատճառով, որ ես իսկապես չեմ հասկանում VBA-ն և ես պարզապես փորձում եմ հարմարեցնել ձերը: Ես մտածում էի, թե կարող եք օգնել: Ես ուզում եմ փոխել ուղղանկյան երկարությունը՝ կախված բջիջի արժեքից: Ես կցանկանայի, որ լայնությունը, եթե ուղղանկյունը մնա նույնը, բայց երկարությունը փոխվեր: Ես կցանկանայի, որ ձախ ձեռքի երկու գագաթները մնան նույն տեղում, և այն երկարացվեր դեպի աջ: Սա հնարավո՞ր է:
Շնորհակալություն
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հարգելի Լան,
Հուսով եմ, որ հետևյալ VBA կոդը կարող է լուծել ձեր խնդիրը: (Խնդրում ենք փոխարինել Oval 1-ը ձեր սեփական ձևի անունով)

Private Sub Worksheet_Change (ByVal Target as Range)
Ս.թ. սխալի Ռեզյումե Next
Եթե ​​Target.Row = 2 Իսկ Target.Column = 1 Ապա
Call SizeCircle («Օվալ 1», Val (Target.Value))
Վերջ: Եթե
Վերջ Sub
Sub SizeCircle (Անունը որպես տող, տրամագիծ)
Dim xCircle որպես ձև
Dim xDiameter As Single
Սխալի դեպքում GoTo ExitSub
xDiameter = Տրամագիծ
Եթե ​​xDiameter > 10, ապա xDiameter = 10
Եթե ​​xDiameter < 1, ապա xDiameter = 1
Սահմանել xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
xCircle-ի հետ
.LockAspectRatio = msoFalse
Լայնություն = Application.CentimetersToPoints(xDiameter)
Վերջ
ExitSub:
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, կա՞ միջոց, որով ես կարող եմ այնպես անել, որ ձևն ընդարձակվի երկու հարթության վրա (ձևի չափը 5-ով մեծացնելու փոխարեն, այն 5-ով մեծացնեմ հորիզոնական և 3-ով ուղղահայաց):
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Հարգելի Սեմ,
Հետևյալ VBA սկրիպտը կարող է օգնել ձեզ լուծել խնդիրը: Եվ երկու չափերը A1 և B1 բջիջներն են:

Private Sub Worksheet_Change (ByVal Target as Range)
Ս.թ. սխալի Ռեզյումե Next
Եթե ​​Target.Count = 1 Ապա
Եթե ​​խաչմերուկ չէ (Թիրախ, միջակայք («A1:B1»)) Ոչինչ է, ուրեմն
Call SizeCircle ("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
Վերջ: Եթե
Վերջ: Եթե
Վերջ Sub
Sub SizeCircle (Անունը որպես տող, Arr որպես տարբերակ)
Dim I As Long
Dim xCenterX որպես միայնակ
Dim xCenterY As Single
Dim xCircle որպես ձև
Սխալի դեպքում GoTo ExitSub
For I = 0 To UBound (Arr)
Եթե ​​Arr(I) > 10 Ապա
Arr(I) = 10
ElseIf Arr(I) < 1 Ապա
Arr(I) = 1
Վերջ: Եթե
հաջորդ
Սահմանել xCircle = ActiveSheet.Shapes(Name)
xCircle-ի հետ
xCenterX = .Ձախ + (. Լայնություն / 2)
xCenterY = .Վերև + (. Բարձրություն / 2)
.Width = Application.CentimetersToPoints(Arr(0))
Բարձրություն = Application.CentimetersToPoints(Arr(1))
Ձախ = xCenterX - (. Լայնություն / 2)
Վերև = xCenterY - (. Բարձրություն / 2)
Վերջ
ExitSub:
Վերջ Sub
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Կա՞ դա Պատկերների միջոցով անելու միջոց: Կարծես բախտ չունեմ օգտագործելու ծածկագիրը, ինչպես տեղադրված է:

5 պատկերներ առաջատար աղյուսակում, ես ուզում եմ, որ 1-ին կամ 1-ի համար կապված պատկերները ավելի մեծ լինեն: Հետևաբար, ես ունեմ 2 ֆիքսված պատկերի չափ, կա՛մ 1x2 ոչ առաջինի համար, կա՛մ 2x4՝ 1-ին տեղում (օրինակ): Ես արդեն կարգավորել եմ վարկանիշը, այնպես որ կարող եմ օգտագործել այն՝ յուրաքանչյուր պատկերի համար հատուկ բջիջներում չափեր ստեղծելու համար (այսինքն՝ օգտագործեք IF հայտարարություն, որպեսզի IF RANK-ը 1-ին չափի լայնությունը լինի 2): Չնայած իմ VBA-ն բավականին թույլ է:

Հիմնականում ես ուզում եմ, թերթի թարմացման վրա, նայեմ պատկերի չափի բջիջներին և յուրաքանչյուր պատկերի չափը սահմանեմ կոնկրետ պատկերի չափի բջիջների արդյունքին: Ես չեմ կարող տեսնել վերևի VBA-ում, թե ինչպես է դա աշխատում, բայց կարծում եմ, որ դա պետք է հեշտ լինի:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև Կրիտալ,

Ես կցանկանայի ձեզ հարցնել, թե արդյոք կա որոշակի բջիջներից գույն (կարմիր բջիջ = կարմիր ձև) և անունը ընտրելու տարբերակ: Կարո՞ղ է նաև VBA-ից ավտոմատ ձևեր ստեղծել:

Կանխավ շատ շնորհակալ եմ :)

Տաղ
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև Կրիտալ
իսկ եթե որոշենք խորանարդի, եռանկյունու, տուփի այն կողմը, որը պետք է որոշվի՝ ելնելով երկարությունից, լայնությունից: Խնդրում եմ օգնիր ինձ

Thank You
աթոռ
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Բարև Նախագահ,
Կներեք, դեռ չեմ կարող օգնել ձեզ այդ հարցում: Շնորհակալություն ձեր մեկնաբանության համար:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
կա՞ արդյոք դա աշխատելու միջոց, եթե բջիջը, որը դուք օգտագործում եք չափը սահմանելու համար, բանաձևի արդյունք է, այլ ոչ թե պարզապես ձեռքով մուտքագրած ստատիկ արժեքի:
Այս մեկնաբանությունը կայքի վարողի կողմից նվազագույնի է հասցվել
Ողջույն, mathnz, ստորև ներկայացված VBA կոդը կարող է օգնել ձեզ լուծել խնդիրը: Դուք պարզապես պետք է փոխեք արժեքային բջիջները և կոդի ձևերի անվանումները՝ հիմնվելով ձեր սեփական տվյալների վրա:
Մասնավոր ենթաթերթ_Calculate()
«Թարմացվել է Extendoffice 20211105
Ս.թ. սխալի Ռեզյումե Next
Call SizeCircle («Օվալ 1», Val (Range («A1»). Արժեք)) «A1-ը արժեքի բջիջն է, Օվալը 1-ը ձևի անունն է
Call SizeCircle («Smiley Face 2», Val (Range («A2»). Արժեք))
Call SizeCircle («Heart 3», Val (Range («A3»). Արժեք))

Վերջ Sub
Private Sub Worksheet_Change (ByVal Target as Range)
Dim xAddress As String
Ս.թ. սխալի Ռեզյումե Next
Եթե ​​Target.CountLarge = 1 Ապա
xAddress = Target.Address(0, 0)
Եթե ​​xAddress = «A1» Ապա
Call SizeCircle («Օվալ 1», Val (Target.Value))
ElseIf xAddress = "A2" Ապա
Call SizeCircle («Smiley Face 2», Val (Target.Value))
ElseIf xAddress = "A3" Ապա
Call SizeCircle ("Heart 3", Val (Target.Value))

Վերջ: Եթե
Վերջ: Եթե
Վերջ Sub

Sub SizeCircle (Անունը որպես տող, տրամագիծ)
Dim xCenterX որպես միայնակ
Dim xCenterY As Single
Dim xCircle որպես ձև
Dim xDiameter As Single
Սխալի դեպքում GoTo ExitSub
xDiameter = Տրամագիծ
Եթե ​​xDiameter > 10, ապա xDiameter = 10
Եթե ​​xDiameter < 1, ապա xDiameter = 1
Սահմանել xCircle = ActiveSheet.Shapes(Name)
xCircle-ի հետ
xCenterX = .Ձախ + (. Լայնություն / 2)
xCenterY = .Վերև + (. Բարձրություն / 2)
Լայնություն = Application.CentimetersToPoints(xDiameter)
Բարձրություն = Application.CentimetersToPoints(xDiameter)
Ձախ = xCenterX - (. Լայնություն / 2)
Վերև = xCenterY - (. Բարձրություն / 2)
Վերջ
ExitSub:
Վերջ Sub

Առայժմ ոչ մի մեկնաբանություն չկա
Թողեք ձեր մեկնաբանությունները
Հրապարակում որպես հյուր
×
Գնահատեք այս գրառումը.
0   Անձնավորություններ
Առաջարկվող վայրեր

Հետեւեք մեզ

Հեղինակային իրավունքի © 2009 - www.extendoffice.com. | Բոլոր իրավունքները պաշտպանված են. Powered by ExtendOffice. | | Կայքի քարտեզ
Microsoft- ը և Office- ի պատկերանշանը հանդիսանում են Microsoft Corporation- ի ապրանքային նշաններ կամ գրանցված ապրանքային նշաններ ԱՄՆ-ում և (կամ) այլ երկրներում:
Պաշտպանված է Sectigo SSL- ի կողմից