VBA-Script automatisch ausführen wenn sich der Inhalt ändert

Hallo Forum,

ich habe folgendes Problem.

Ich möchte in Excel per VBA Beplankungslagen einer Holzbalkendecke (als farbige Rechtecke) zeichnen lassen, d.h.:

- in Zelle A2 bzw. A3 wähle ich die Art der Beplankung (OSB, Dielen) aus
- in Zelle C2 bzw. C3 wähle ich die Dicke der jeweiligen Beplankung aus
- in den Zellen E2 bzw. E3 werden automatisch die Abstände der rechten oberen Ecke der Rechtecke zur schwarzen "Nulllinie" errechnet.
Dies ist notwendig da sich die jeweiligen Rechtecke, je nach ausgewählter Dicke, in der Lage verändern. Dies ist aber für meine Frage nicht
relevant.

Ich habe nun das Problem das die Rechtecke erst gezeichnet werden, wenn ich in die Zelle E2 bzw. E3 klicke und mit "Enter" bestätige. Dies
soll aber automatisch erfolgen, sobald sich der Wert ändert. Dies ist der Fall wenn die Dicke geändert wird. Im nächsten Schritt sollten, wenn ich
eine andere Stärke wähle die zuvor gezeichneten Rechtecke gelöscht werden und aktuelle gezeichnet werden.
Vorlage:
https://www.herber.de/bbs/user/165915.xlsm

Über eine Hilfestellung würde ich mich sehr freuen und bedanke mich schon im voraus.

Vielen Dank und Gruß
götzi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code:

Sub Oberseite_X_Lage(Target As Range)
 Dim oShp As Object, sName As String
  
 With Target
     If .Address = "$C$2" Or .Address = "$C$3" Then        ' Nur bei Änderungen in C2,C3
        sName = "Oberseite_" & .Row & "_Lage"              ' Name des Objekts
        On Error Resume Next
        Set oShp = .Parent.Shapes.Range(Array(sName))      ' Objekt ansprechen
        If Not oShp Is Nothing Then oShp.Delete            ' ggf. Objekt löschen
        On Error GoTo 0
'       Objekt neu kreieren                Wert aus E2,E3           Wert aus C2,C3
        Set oShp = .Parent.Shapes.AddShape(1, 100, .Offset(0, 2).Value, 200, .Value)
        oShp.Name = sName                                  ' Namen vergeben
        oShp.Fill.ForeColor.RGB = IIf(.Row = 2, RGB(212, 237, 252), RGB(162, 218, 244))
        oShp.Line.ForeColor.RGB = oShp.Fill.ForeColor.RGB  ' Farbe setzen
     End If
  End With
End Sub

Code:

Sub Oberseite_X_Lage(Target As Range)
 Dim oShp As Object, oShpL As Object, sName As String
 Dim iPos As Long, iDick(3) As Long, i As Integer
  
 If Target.Address = "$C$2" Or Target.Address = "$C$3" Then     ' Bei Änderungen in C2,C3
    Set oShpL = Tabelle1.Shapes.Range("Gerader Verbinder 1161") ' Linie ansprechen
    For i = 2 To 3
        sName = "Oberseite_" & (i - 1) & "_Lage"                ' Name des Objekts
        
        On Error Resume Next
        Set oShp = Nothing
        Set oShp = Tabelle1.Shapes.Range(sName)                 ' Objekt ansprechen
        If Not oShp Is Nothing Then oShp.Delete                 ' ggf. Objekt löschen
        On Error GoTo 0
        
        iDick(i) = Tabelle1.Cells(i, "C").Value                 ' Dicke der Linie
        iPos = oShpL.Top - iDick(i) - iDick(i - 1)              ' Position der Linie

' Objekt neu kreieren
        Set oShp = Tabelle1.Shapes.AddShape(1, 100, iPos, 200, iDick(i))
        oShp.Name = sName                                       ' Namen vergeben
        oShp.Fill.ForeColor.RGB = IIf(i = 2, RGB(212, 237, 252), RGB(162, 218, 244))
        oShp.Line.ForeColor.RGB = oShp.Fill.ForeColor.RGB       ' Farbe setzen
    Next i
  End If
End Sub

Hallo Goetzi,

wenn man weiß, was der Kunde genau möchte, kann man auch ganz andere Ideen entwickeln.

Hier noch mal etwas Neues, bei der die Farbe nicht von der Zeile, sondern vom Eintrag in $A abhängt. Da kannst Du jetzt beliebig viele Farben verwenden.

Außerdem, warum sollte immer (nach Löschung) ein neues Objekt angelegt werden. Das machen wir jetzt nur noch einmal (wenn kein Objekt da ist) und verwenden immer die schon vorhandenen Rechtecke...
Und wir machen die Rechtecke komplett abhängig von der (Steuer)linie. Wenn Du diese jetzt verschiebst oder verbreiterst folgen die Rechtecke dieser Änderung.

Du siehst, mit VBA ist alles möglich, meist sogar auf 'zig verschiedenen Wegen.

Wenn Du Fragen hast, kannst Du dich gerne hier melden. Aber der Code ist natürlich auch kommentiert.

Code:


Sub Oberseite_X_Lage(Target As Range)
 Dim oShp As Object, oShpL As Object, sName As String
 Dim iPos As Long, iDick(3) As Long, iFarbe As Long, i As Integer
  
 If InStr("$C$2 $C$3 $A$2 $A$3", Target.Address) > 0 Then  ' Bei Änderungen
    Set oShpL = Tabelle1.Shapes.Range("Gerader Verbinder 1161") ' Linie ansprechen
    
    For i = 2 To 3
        sName = "Oberseite_" & (i - 1) & "_Lage"    ' Name des Rechtecks
        iDick(i) = Tabelle1.Cells(i, "C").Value     ' Dicke der Linie
        iPos = oShpL.Top - iDick(i) - iDick(i - 1)  ' Position der Linie
        
        On Error Resume Next
        Set oShp = Nothing
        Set oShp = Tabelle1.Shapes.Range(sName)     ' Rechteck ansprechen
        If oShp Is Nothing Then                     ' Rechteck neu anlegen
           Set oShp = Tabelle1.Shapes.AddShape(1, 10, iPos, 10, 10)
           oShp.Name = sName                        ' Namen vergeben
        End If
        On Error GoTo 0

        Select Case Tabelle1.Cells(i, "A").Value    ' Farbe bestimmen
        Case "OSB":          iFarbe = RGB(212, 237, 252)
        Case "Holzschalung": iFarbe = RGB(162, 218, 244)
        Case Else
        End Select
        
' Rechteck bearbeiten
        With oShp
           .Top = iPos                              ' Position Top
           .Height = iDick(i)                       ' Höhe (Dicke) setzen
           .Left = oShpL.Left + 40                  ' Position links
           .Width = oShpL.Width - 80                ' Breite
           .Fill.ForeColor.RGB = iFarbe             ' Farbe setzen
           .Line.ForeColor.RGB = iFarbe
        End With
    Next i
  End If
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

VBA-Script automatisch ausführen wenn sich der Inhalt ändert

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA-Script automatisch ausführen wenn sich der Inhalt ändert

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread