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

Jak automatycznie zmienić rozmiar kształtu na podstawie / w zależności od określonej wartości komórki w programie Excel?

Jeśli chcesz automatycznie zmienić rozmiar kształtu na podstawie wartości określonej komórki, ten artykuł może Ci pomóc.

Automatycznie zmieniaj rozmiar kształtu na podstawie określonej wartości komórki za pomocą kodu VBA


Automatycznie zmieniaj rozmiar kształtu na podstawie określonej wartości komórki za pomocą kodu VBA

Poniższy kod VBA może pomóc w zmianie określonego rozmiaru kształtu na podstawie określonej wartości komórki w bieżącym arkuszu. Wykonaj następujące czynności.

1. Kliknij prawym przyciskiem myszy zakładkę arkusza z kształtem, którego rozmiar chcesz zmienić, a następnie kliknij Wyświetl kod z menu po kliknięciu prawym przyciskiem myszy.

2. w Microsoft Visual Basic for Applications okno, skopiuj i wklej następujący kod VBA do okna Code.

Kod VBA: Automatyczna zmiana rozmiaru kształtu na podstawie określonej wartości komórki w programie 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

Uwagi: W kodzie „Owalny 2”To nazwa kształtu, którego rozmiar zmienisz. I Rząd = 2, Kolumna = 1 oznacza, że ​​rozmiar kształtu „Owal 2” zostanie zmieniony na wartość z A2. Zmień je według potrzeb.

Aby automatycznie zmienić rozmiar wielu kształtów na podstawie różnych wartości komórek, zastosuj poniższy kod VBA.

Kod VBA: Automatycznie zmieniaj rozmiar wielu kształtów na podstawie różnych określonych wartości komórek w programie 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

Uwagi:

1) W kodzie „Owalny 1","Buźka 3"I"Serce 3”To nazwy kształtów, których rozmiary zmienisz automatycznie. I A1, A2 iA3 to komórki, na podstawie których automatycznie zmieniasz rozmiar kształtów.
2) Jeśli chcesz dodać więcej kształtów, dodaj linie "ElseIf xAddress = "A3" Następnie" i „Call SizeCircle („ Heart 2 ”, Val (Target.Value))„powyżej pierwszego”End If”w kodzie. Zmień adres komórki i nazwę kształtu w zależności od potrzeb.

3. naciśnij inny + Q klawisze jednocześnie, aby zamknąć Microsoft Visual Basic for Applications okno.

Od teraz, gdy zmienisz wartość w komórce A2, rozmiar kształtu Oval 2 zostanie automatycznie zmieniony. Zobacz zrzut ekranu:

Lub zmień wartości w komórkach A1, A2 i A3, aby automatycznie zmienić rozmiar odpowiednich kształtów „Owal 1”, „Buźka 3” i „Serce 3”. Zobacz zrzut ekranu:

Uwagi: Rozmiar kształtu nie będzie się już zmieniać, gdy wartość komórki będzie większa niż 10.


Wyświetl i wyeksportuj wszystkie kształty w bieżącym skoroszycie programu Excel:

Podróż Ruta de la Plata w liczbach Eksportuj grafikę użyteczność Kutools dla programu Excel pomagają szybko wyświetlić wszystkie kształty w bieżącym skoroszycie i możesz wyeksportować je wszystkie do określonego folderu naraz, jak pokazano na poniższym zrzucie ekranu. Pobierz i wypróbuj teraz! (30-dzień wolny szlak)


Podobne artykuły:


Najlepsze narzędzia biurowe

Kutools dla programu Excel rozwiązuje większość problemów i zwiększa produktywność o 80%

  • Ponowne użycie: Szybko włóż złożone wzory, wykresy i wszystko, czego używałeś wcześniej; Szyfruj komórki z hasłem; Utwórz listę mailingową i wysyłaj e-maile ...
  • Pasek Super Formula (łatwo edytować wiele wierszy tekstu i formuły); Układ do czytania (łatwe odczytywanie i edytowanie dużej liczby komórek); Wklej do filtrowanego zakresu...
  • Scal komórki / wiersze / kolumny bez utraty danych; Podziel zawartość komórek; Połącz zduplikowane wiersze / kolumny... Zapobiegaj zduplikowanym komórkom; Porównaj zakresy...
  • Wybierz Duplikat lub Unikalny Wydziwianie; Wybierz puste wiersze (wszystkie komórki są puste); Super Find i Fuzzy Find w wielu zeszytach ćwiczeń; Losowy wybór ...
  • Dokładna kopia Wiele komórek bez zmiany odwołania do formuły; Automatyczne tworzenie odniesień do wielu arkuszy; Wstaw punktory, Pola wyboru i nie tylko ...
  • Wyodrębnij tekst, Dodaj tekst, Usuń według pozycji, Usuń przestrzeń; Tworzenie i drukowanie podsumowań stronicowania; Konwertuj zawartość komórek i komentarze...
  • Super filtr (zapisz i zastosuj schematy filtrów do innych arkuszy); Zaawansowane sortowanie według miesiąca / tygodnia / dnia, częstotliwości i innych; Specjalny filtr pogrubieniem, kursywą ...
  • Połącz skoroszyty i arkusze robocze; Scal tabele na podstawie kluczowych kolumn; Podziel dane na wiele arkuszy; Konwersja wsadowa xls, xlsx i PDF...
  • Ponad 300 zaawansowanych funkcji. Obsługuje Office / Excel 2007-2021 i 365. Obsługuje wszystkie języki. Łatwe wdrażanie w przedsiębiorstwie lub organizacji. Pełne funkcje 30-dniowa bezpłatna wersja próbna. 60-dniowa gwarancja zwrotu pieniędzy.
karta kte 201905

Karta Office wprowadza interfejs z zakładkami do pakietu Office i znacznie ułatwia pracę

  • Włącz edycję i czytanie na kartach w programach Word, Excel, PowerPoint, Publisher, Access, Visio i Project.
  • Otwieraj i twórz wiele dokumentów w nowych kartach tego samego okna, a nie w nowych oknach.
  • Zwiększa produktywność o 50% i redukuje setki kliknięć myszką każdego dnia!
officetab dół
Sortuj komentarze według
Komentarze (16)
Brak ocen. Oceń jako pierwszy!
Ten komentarz został zminimalizowany przez moderatora na stronie
Jak byś to wykonał z wieloma kształtami, z których każdy zależy od różnych komórek?
Ten komentarz został zminimalizowany przez moderatora na stronie
Drogi Jade,
Artykuł został zaktualizowany o nową sekcję kodu, która może pomóc w wykonaniu z wieloma kształtami, z których każdy zależy od różnych komórek. Dziękuję za Twój komentarz.

Z poważaniem,
Kryształ
Ten komentarz został zminimalizowany przez moderatora na stronie
Jak nazwać swój kształt? Jak w powyższym przykładzie przypisać nazwę Oval 2 do narysowanego koła?
Ten komentarz został zminimalizowany przez moderatora na stronie
Drogi Ranjicie,
Aby nazwać kształt, wybierz ten kształt, wprowadź nazwę kształtu w polu nazwy, a następnie naciśnij klawisz Enter. Zobacz poniższy obrazek.
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć, jak powielić to samo dla wielu kształtów połączonych z wieloma komórkami w tym samym module?
Ten komentarz został zminimalizowany przez moderatora na stronie
Droga Abhinaya,
Artykuł został zaktualizowany o nową sekcję kodu, która może pomóc w wykonaniu z wieloma kształtami, z których każdy zależy od różnych komórek. Dziękuję za Twój komentarz.

Z poważaniem,
Kryształ
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć,
Próbowałem użyć twojego posta do napisania własnego kodu VBA, ale wydaje mi się, że nie zaszedłem zbyt daleko. Głównie dlatego, że tak naprawdę nie rozumiem VBA i po prostu staram się dostosować twój. Zastanawiałem się, czy mógłbyś pomóc. Chcę zmienić długość prostokąta w zależności od wartości w komórce. Chciałbym, aby szerokość prostokąta pozostała taka sama, ale długość się zmieniła. Chciałbym, aby oba wierzchołki lewej ręki pozostały w tym samym miejscu i wydłużyły się w prawo. czy to możliwe?
Dziękuję Ci
Ten komentarz został zminimalizowany przez moderatora na stronie
Drogi Lan,
Mam nadzieję, że poniższy kod VBA może rozwiązać Twój problem. (Proszę zastąpić Oval 1 własną nazwą kształtu)

Prywatny Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Jeśli Target.Row = 2 I Target.Column = 1 Wtedy
Zadzwoń SizeCircle("Owal 1", Val(Target.Value))
End If
End Sub
Sub SizeCircle (nazwa jako ciąg, średnica)
Dim xOkrąg jako kształt
Dim x Średnica jako pojedynczy
W przypadku błędu IdźDo WyjdźSub
xŚrednica = Średnica
Jeśli xDiameter > 10 to xDiameter = 10
Jeśli xDiameter < 1 Wtedy xDiameter = 1
Ustaw xCircle = ActiveSheet.Shapes(Nazwa)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Z xCircle
.LockAspectRatio = msoFalse
.Width = Aplikacja.CentimetersToPoints(xDiameter)
Kończyć z
ExitSub:
End Sub
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć, czy jest jakiś sposób, aby powiększyć kształt w dwóch wymiarach (zamiast zwiększania rozmiaru kształtu o 5, zwiększ go o 5 w poziomie i 3 w pionie)?
Ten komentarz został zminimalizowany przez moderatora na stronie
Drogi Sam,
Poniższy skrypt VBA może pomóc w rozwiązaniu problemu. A te dwa wymiary to komórki A1 i B1.

Prywatny Sub Worksheet_Change (ByVal Target As Range)
On Error Resume Next
Jeśli Target.Count = 1 Wtedy
Jeśli nie przecina(cel, zakres("A1:B1")) to nic wtedy
Wywołaj SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
End If
End If
End Sub
Sub SizeCircle (nazwa jako ciąg, Arr jako wariant)
Dim I tak długo
Dim xCenterX jako pojedynczy
Dim xCenterY jako pojedynczy
Dim xOkrąg jako kształt
W przypadku błędu IdźDo WyjdźSub
Dla I = 0 To UBound(Arr)
Jeśli Arr(I) > 10 Wtedy
Arr(I) = 10
ElseIf Arr(I) < 1 Wtedy
Arr(I) = 1
End If
Dalej
Ustaw xCircle = ActiveSheet.Shapes(Nazwa)
Z xCircle
xCenterX = .Lewo + (.Szerokość / 2)
xCenterY = .Góra + (.Wysokość / 2)
.Width = Aplikacja.CentimetersToPoints(Arr(0))
.Wysokość = Aplikacja.CentimetersToPoints(Arr(1))
.Lewo = xCenterX - (.Width / 2)
.Top = xCenterY - (.Wysokość / 2)
Kończyć z
ExitSub:
End Sub
Ten komentarz został zminimalizowany przez moderatora na stronie
Czy można to zrobić z obrazami? Wygląda na to, że nie mam szczęścia w korzystaniu z zamieszczonego kodu.

5 Obrazy w tabeli liderów, chcę, aby obrazy na 1. miejscu lub remis na 1. miejscu były większe. Dlatego mam 2 stałe rozmiary obrazu, 1x2 dla nie pierwszego lub 2x4 dla pierwszego miejsca (na przykład). Mam już skonfigurowany ranking, więc mogę go użyć do tworzenia rozmiarów w określonych komórkach dla każdego obrazu (tj. Użyj instrukcji IF, aby IF RANK był pierwszym rozmiarem, a szerokość 1). Mój VBA jest jednak dość słaby.

Zasadniczo chcę - w aktualizacji arkusza - spojrzeć na komórki rozmiaru obrazu i ustawić każdy rozmiar obrazu na wynik określonego rozmiaru komórek. Nie widzę w powyższym VBA, jak to dokładnie działa, ale myślę, że powinno to być łatwe!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Kryształ,

Chciałabym zapytać, czy jest sposób na wybranie koloru (czerwona komórka = czerwona forma) i nazwy z konkretnych komórek. czy możliwe jest również automatyczne tworzenie formularzy z VBA?

Z góry bardzo dziękuję :)

kolęda
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Kryształ
co by było, gdyby określić bok sześcianu, trójkąta, pudełka, które należy określić na podstawie długości, szerokości? Proszę pomóż mi

Dziękuję Ci
krzesło
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć,
Przepraszamy, nie mogę ci jeszcze w tym pomóc. Dzięki za komentarz.
Ten komentarz został zminimalizowany przez moderatora na stronie
czy istnieje sposób, aby to zadziałało, jeśli komórka używana do ustawienia rozmiaru jest wynikiem formuły, a nie tylko wartością statyczną, którą wprowadzasz ręcznie?
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć mathnz, Poniższy kod VBA może pomóc w rozwiązaniu problemu. Wystarczy zmienić komórki wartości i nazwy kształtów w kodzie na podstawie własnych danych.
Prywatny arkusz pomocniczy_Oblicz()
'Aktualizowany przez Extendoffice 20211105
On Error Resume Next
Zadzwoń SizeCircle("Owal 1", Val(Range("A1").Value)) 'A1 to komórka wartości, Oval 1 to nazwa kształtu
Zadzwoń SizeCircle ("Smiley Face 2", Val(Range("A2").Value))
Zadzwoń SizeCircle("Serce 3", Val(Range("A3").Value))

End Sub
Prywatny Sub Worksheet_Change (ByVal Target As Range)
Dim xAddress jako ciąg
On Error Resume Next
Jeśli Target.CountLarge = 1 Wtedy
xAdres = Cel.Adres(0, 0)
Jeśli xAddress = „A1” Wtedy
Zadzwoń SizeCircle("Owal 1", Val(Target.Value))
ElseIf xAddress = "A2" Następnie
Call SizeCircle("Uśmiechnięta buźka 2", Val(Target.Value))
ElseIf xAddress = "A3" Następnie
Call SizeCircle("Serce 3", Val(Target.Value))

End If
End If
End Sub

Sub SizeCircle (nazwa jako ciąg, średnica)
Dim xCenterX jako pojedynczy
Dim xCenterY jako pojedynczy
Dim xOkrąg jako kształt
Dim x Średnica jako pojedynczy
W przypadku błędu IdźDo WyjdźSub
xŚrednica = Średnica
Jeśli xDiameter > 10 to xDiameter = 10
Jeśli xDiameter < 1 Wtedy xDiameter = 1
Ustaw xCircle = ActiveSheet.Shapes(Nazwa)
Z xCircle
xCenterX = .Lewo + (.Szerokość / 2)
xCenterY = .Góra + (.Wysokość / 2)
.Width = Aplikacja.CentimetersToPoints(xDiameter)
.Wysokość = Zastosowanie.CentymetryDoPunktów(xŚrednica)
.Lewo = xCenterX - (.Width / 2)
.Top = xCenterY - (.Wysokość / 2)
Kończyć z
ExitSub:
End Sub

Nie ma tu jeszcze żadnych komentarzy
Zostaw swój komentarz
Publikowanie jako gość
×
Oceń ten post:
0   Postacie
Sugerowane lokalizacje

Bądż na bieżąco

Prawa autorskie © 2009 - www.extendoffice.com. | Wszelkie prawa zastrzeżone. Zasilany przez ExtendOffice, | Mapa strony
Microsoft i logo Office są znakami towarowymi lub zastrzeżonymi znakami towarowymi Microsoft Corporation w Stanach Zjednoczonych i / lub innych krajach.
Chronione przez Sectigo SSL