Office: (Office 2013) VBA Autoform einfärben

Hallo Karin,

ich bin es nocheinmal. Es klappt soweit alles wunderbar. Nachdem ich nun noch viele weitere Autoformen hinzugefügt habe, kommt die Fehlermeldung, dass die Prozedur zu groß ist. Jetzt habe ich versucht, meinen Code in zwei Prozeduren zu unterteilen, aber leider erfolglos.
Kannst du mir sagen, wie ich den Code anpassen muss.

Beste Grüße
stseca

 

Hi,

das kann ich so nicht nachvollziehen, dazu musst du schon mal die Mappe hochladen.

Bis später,
Karin

 

Hallo,

die Datei ist leider zu groß zum Hochladen. Ich habe jetzt nur meinen Code in eine Datei eingefügt. Hoffe, dass das hilft.
Oder kann ich dir die Datei anders zukommen lassen?

Liebe Grüße
stseca

 

Hi,

lade eine Kopie deiner Mappe mit nur einigen Tabellenblättern hoch. Wahrscheinlich muss das in einer Schleife gelöst werden oder komplett anders.

Bis später,
Karin

 

Hallo,

ich habe mal einen Link über file upload erstellt. Da ist die ganze Datei zu finden. War mir nicht sicher, ob du darüber gehen möchtest.

https://www.file-upload.net/download-13272457/Mappe1.xlsm.html

Lieben Gruß
stseca

 

Hi,

von File upload lade ich nichts herunter, da ich dort schon schlechte Erfahrungen gemacht habe.
Auf meiner Homepage http://excel-inn.de/ unter Impressum findest du meine E-Mailadresse.

Bis später,
Karin

 

Hallo,

kein Problem. Ich habe dir eine E-Mail geschrieben:)

Grüße
stseca

 

Hi,

ausgehend von deiner Mappe musst du folgendes machen: benenne alle Shapes um - entsprechend der Zelle auf die es sich beziehen soll. Beachte dabei aber, dass du ans Ende noch einen Unterstrich setzt, weil Zelladressen nicht als Name für ein Shape verwendet werden dürfen - also z.B. C11_ D11_ F11_ usw. Da es sich um sehr viele Shapes handelt empfehle ich dir, dies nur für 1 Tabellenblatt auszuführen und dasnn das komplette Tabellenblatt zu kopieren - dann bleiben die Namen der Shapes erhalten. Allerdings musst du dann logischerweise die Formeln ändern und auf die betreffende Spalte im Tabellenblatt "Übersicht" beziehen - das ist jedoch wesentlich einfacher, als wenn du jedes Shape in jedem Tabellenblatt von Hand ändern musst, denn das kannst du über Suchen -> Ersetzen realisieren.

Danach kannst du folgenden Code verwenden:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim shaShape As Shape
    Dim strZelle As String
    Dim strTabelle As String
    Dim blnAusfuehren As Boolean
    If Not Intersect(Target, Columns(11)) Is Nothing Then
        If UCase(Target.Cells(1)) = "X" Then
            strTabelle = "DEBI"
            blnAusfuehren = True
        End If
    ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
        If UCase(Target.Cells(1)) = "X" Then
            strTabelle = "Messgrößen"
            blnAusfuehren = True
        End If
    ElseIf Not Intersect(Target, Columns(13)) Is Nothing Then
        If UCase(Target.Cells(1)) = "X" Then
            strTabelle = "Prozessverantwortung"
            blnAusfuehren = True
        End If
    ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
        If UCase(Target.Cells(1)) = "X" Then
            strTabelle = "ChancenRisiken"
            blnAusfuehren = True
        End If
    End If
    If blnAusfuehren Then
        With Worksheets(strTabelle)
            For Each shaShape In .Shapes
                If shaShape.AutoShapeType = 51 Or shaShape.AutoShapeType = 52 Then
                    strZelle = Application.Substitute(shaShape.Name, "_", "")
                    If .Range(strZelle).Value > 79 Then
                        shaShape.Fill.ForeColor.RGB = RGB(0, 179, 0)
                    ElseIf .Range(strZelle).Value > 30 And Range(strZelle).Value < 80 Then
                        shaShape.Fill.ForeColor.RGB = RGB(255, 255, 0)
                    ElseIf .Range(strZelle).Value < 31 Then
                        shaShape.Fill.ForeColor.RGB = RGB(238, 0, 0)
                    End If
                End If
            Next shaShape
        End With
    End If
End Sub

Noch einfacher wäre der Code, wenn die Spaltenüberschiften in Tabelle "Übersicht" den genauen Tabellennamen rerpäsentieren würden, da man den Code dann nicht extra nach Spaltennummer unterscheiden müsste.


Bis später,
Karin

 

Hallo Karin,

ich habe alles befolgt was du gesagt hast, bekomme allerdings die Fehlermeldung wie in den Screenshots dargestellt.
Woran könnte das liegen?

Lieben Gruß
stseca

 

Hi,

das kann ich so nicht ohne weiteres sagen, aber ich würde annehmen, dass die Variable strZelle entweder leer ist oder einen Inhalt hat, der nicht als Zelladresse interpretiert werden kann. Musst du halt mal im Einzelschrittmodus durchlaufen und sehen, weshalb sie falsch gefüllt wird.

Bis später,
Karin

 

Hey,

tut mir leid, aber auf was genau bezieht sich denn die Variable strZelle?

Lieben Gruß
stseca

 

Hi,

hast du - wie ich in meinem Beitrag von 14.08.2018, 16:21 geschrieben habe - alle deine Shapes enstprechend umbenannt?

Bis später,
Karin

 

Hey,

die Shapes sind die einzelnen Formen richtig? Ja das habe ich gemacht. Habe sie enstprechend der Zelle (auf dem gleichen Arbeitsblatt) auf die es sich beziehen soll, umbenannt.

Grüße
stseca

 

Hi,

ja, mit Shapes meine ich deine Formen.
Ich habe den Code in deiner Mappe getestet und erhalte keine Fehlermeldung. In der angehängten Mappe habe ich das mal für einige Shapes in Tabelle DEBI realisiert (habe sie erstmal weiß gefärbt damit du nach Codedurcblauf die Änderung siehst). Gib einfach in der Tabelle Übersicht in der grau formatierten Zelle ein x ein - der Code wird ausgeführt und färbt die Shapes im Tabellenblatt DEBI
Es ist also anzunehmen, dass (mindestens) 1 der Shapes nicht korrekt umbenannt wurde. Du kannst das mit folgendem Code prüfen:

Code:

Sub NamePruefen()
    Dim shaShape As Shape
    Dim wksTab As Worksheet
    For Each wksTab In Worksheets
        For Each shaShape In wksTab.Shapes
            If shaShape.AutoShapeType = 51 Or shaShape.AutoShapeType = 52 Then
                If Right(shaShape.Name, 1) <> "_" Then
                    shaShape.Parent.Activate
                    shaShape.Select
                    Exit Sub
                End If
            End If
        Next shaShape
    Next wksTab
End Sub

Der Code läuft über alle Tabellenblätter und darin über alle Shapes. Wird eins gefunden, welches keinen "_" am Ende des Namen hat, wird das Tabellenblatt aktiviert, das Shapes selektiert und der Code abgebrochen, sodass du sehen kannst, welches Shape es ist und den Namen ändern kannst. Du musst den Code also mehrmals durchlaufen lassen bis er ohne ein Shape zu aktivieren durchläuft.


Bis später,
Karin

 

Hey,

danke dir! Es klappt soweit, aber es gibt immer noch ein Problem. Die Farben ändern sich nur, wenn ich die Daten der Reihenfolge nach ändere. Wenn ich die Daten aber willkürlich ändere, dann passiert garnichts.
Bei Chancen und Risiken geht leider auch garnichts. Du hast in deinem Code beim Part "ChancenundRisiken" Columns (12) angegeben. Das soll warscheinlich Columns (14) sein, richtig?

Grüße
stseca