Kreis - Rechteck dynamisch | HERBERS Excel Forum

Forumthread: Kreis - Rechteck dynamisch

Kreis - Rechteck dynamisch

24.06.2020 08:21:58

Tobias

Hallo zusammen,
Auf einem Excel-Tabellenblatt habe ich einen Kreis gezeichnet. Dieser Kreis / Reckeck soll abhängig von einem gewissen Durchmesser / Höhe / Breit Wert in einer Zelle seine Größe ändern, jedoch darf er dabei nicht seine Position (bzw. den Mittelpunkt) auf dem Tabellenblatt nicht ändern.
Kann mir vielleicht jemand einen Tipp geben wie ich das hinbekomme?
Mit freundlichen Grüßen
Tobias

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Kreis - Rechteck dynamisch

24.06.2020 08:26:23

Tobias
AW: Kreis - Rechteck dynamisch

24.06.2020 09:22:30

MCO

AW: Kreis - Rechteck dynamisch

24.06.2020 09:22:30

MCO

Hallo Tobias!
Deine Figuren haben alle Breite und Höhe als Eigenschaft. Damit kannst du den Mittelpunkt bestimmen (jeweils geteilt durch 2) indem du die Position der Figur + Abmessungen nimmst.
Alte Mitte mit neuen Abmessungen = neue Position
Als code sieht das dann so aus:

Sub Größe_andern_Kreis()
With ActiveSheet.Shapes.Range(Array("Oval 2"))
Mitte_vert = .Top + .Height / 2
Mitte_hori = .Left + .Width / 2
.Height = Application.CentimetersToPoints(Range("B5"))
.Width = .Height
.Top = Mitte_vert - .Height / 2
.Left = Mitte_hori - .Width / 2
End With
End Sub



Sub Größe_andern_Rechteck()

With ActiveSheet.Shapes.Range(Array("Rectangle 5"))

Mitte_vert = .Top + .Height / 2

Mitte_hori = .Left + .Width / 2

.Height = Application.CentimetersToPoints(Range("K5"))

.Width = Application.CentimetersToPoints(Range("K6"))

.Top = Mitte_vert - .Height / 2

.Left = Mitte_hori - .Width / 2

End With

End Sub

In Tabelle1 gehört noch dieser Code

Private Sub Worksheet_Change(ByVal Target As Range)
If Target = "" Then Exit Sub
If Not IsNumeric(Target) Then Exit Sub
Set Eingabe_kreis = Application.Intersect(Target, Range("B5"))
Set Eingabe_Ø = Application.Intersect(Target, Range("K5:K6"))
If Not Eingabe_kreis Is Nothing Then Größe_andern_Kreis
If Not Eingabe_Ø Is Nothing Then Größe_andern_Rechteck
End Sub

https://www.herber.de/bbs/user/138514.xlsm
Gruß, MCO

Infobox / Tutorial

Dynamische Anpassung von Kreis und Rechteck in Excel

Schritt-für-Schritt-Anleitung
Häufige Fehler und Lösungen
Alternative Methoden
Praktische Beispiele
Tipps für Profis
FAQ: Häufige Fragen

Schritt-für-Schritt-Anleitung

Um die Größe eines Kreises und eines Rechtecks in Excel dynamisch anzupassen, ohne deren Position zu verändern, folge diesen Schritten:

Vorbereitung des Excel-Blattes:
- Erstelle einen Kreis und ein Rechteck auf deinem Excel-Blatt. Benenne die Formen, falls nötig (z.B. "Oval 2" für den Kreis und "Rectangle 5" für das Rechteck).

Einfügen des VBA-Codes:

Öffne den VBA-Editor mit ALT + F11.
Füge ein neues Modul hinzu und kopiere den folgenden Code hinein:

Sub Größe_andern_Kreis()
   With ActiveSheet.Shapes.Range(Array("Oval 2"))
       Mitte_vert = .Top + .Height / 2
       Mitte_hori = .Left + .Width / 2
       .Height = Application.CentimetersToPoints(Range("B5"))
       .Width = .Height
       .Top = Mitte_vert - .Height / 2
       .Left = Mitte_hori - .Width / 2
   End With
End Sub

Sub Größe_andern_Rechteck()
   With ActiveSheet.Shapes.Range(Array("Rectangle 5"))
       Mitte_vert = .Top + .Height / 2
       Mitte_hori = .Left + .Width / 2
       .Height = Application.CentimetersToPoints(Range("K5"))
       .Width = Application.CentimetersToPoints(Range("K6"))
       .Top = Mitte_vert - .Height / 2
       .Left = Mitte_hori - .Width / 2
   End With
End Sub

Implementierung des Worksheet_Change-Events:

Füge den folgenden Code in das entsprechende Tabellenblatt ein:

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target = "" Then Exit Sub
   If Not IsNumeric(Target) Then Exit Sub
   Set Eingabe_kreis = Application.Intersect(Target, Range("B5"))
   Set Eingabe_Ø = Application.Intersect(Target, Range("K5:K6"))
   If Not Eingabe_kreis Is Nothing Then Größe_andern_Kreis
   If Not Eingabe_Ø Is Nothing Then Größe_andern_Rechteck
End Sub

Eingabewerte festlegen:
- Trage in die Zellen B5, K5 und K6 die gewünschten Werte für den Durchmesser und die Abmessungen des Rechtecks ein.
Testen:
- Ändere die Werte in den Zellen und beobachte, wie sich der Kreis und das Rechteck dynamisch anpassen.

Häufige Fehler und Lösungen

Fehler: Die Formen bewegen sich
Lösung: Stelle sicher, dass der Code die Position nach der Größenänderung korrekt berechnet. Vergewissere dich, dass die Mitte_vert und Mitte_hori korrekt gesetzt sind.
Fehler: Shapes sind nicht gefunden
Lösung: Überprüfe die Namen der Shapes. Diese müssen exakt im Code übereinstimmen.

Alternative Methoden

Falls du die dynamische Anpassung ohne VBA umsetzen möchtest, kannst du auch die Formel-Optionen in Excel verwenden, um die Größe der Formen an die Eingabewerte zu binden. Dies ist jedoch weniger flexibel und kann je nach Excel-Version unterschiedlich sein.

Praktische Beispiele

Beispiel 1: Ein Durchmesser von 10 cm für den Kreis in Zelle B5 und ein Rechteck mit 5 cm Höhe und 8 cm Breite in K5 und K6.
Beispiel 2: Verwende die Formeln in den Zellen, um die Werte automatisch aus anderen Zellen zu berechnen und die Figuren entsprechend zu ändern.

Tipps für Profis

Nutze die Möglichkeit, den VBA-Code zu erweitern, um verschiedene Formen gleichzeitig anzupassen.
Experimentiere mit verschiedenen Maßeinheiten, indem du die Application.CentimetersToPoints-Funktion anpasst.
Halte deine Shapes ordentlich benannt, um die Wartung des Codes zu erleichtern.

FAQ: Häufige Fragen

1. Kann ich mehrere Formen gleichzeitig anpassen?
Ja, du kannst die With-Anweisung im VBA-Code erweitern, um mehrere Shapes gleichzeitig anzusprechen.

2. Welche Excel-Version benötige ich für dieses Feature?
Die beschriebenen Methoden funktionieren in den meisten aktuellen Excel-Versionen, die VBA unterstützen, wie Excel 2016, 2019 und Microsoft 365.

Beliebteste Forumthreads (12 Monate)