Seite 3 von 3 ErsteErste 1 2 3
Ergebnis 21 bis 23 von 23

Thema: VBA Autoform einfärben (Office 2013)

  1. #21
    Office-Hilfe.com - Legende
    Registriert seit
    26.08.2009
    Ort
    Bergstadt Freiberg/Sa.
    Beiträge
    2.676
    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
    Standard: Win 10, Office 2016
    Bei Bedarf auch Excel 97 - 2013

  2. #22
    Office-Hilfe.com - Neuling
    Registriert seit
    09.08.2018
    Beiträge
    13
    Hallo,

    kein Problem. Ich habe dir eine E-Mail geschrieben

    Grüße
    stseca

  3. #23
    Office-Hilfe.com - Legende
    Registriert seit
    26.08.2009
    Ort
    Bergstadt Freiberg/Sa.
    Beiträge
    2.676
    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
    Standard: Win 10, Office 2016
    Bei Bedarf auch Excel 97 - 2013

Stichworte

Berechtigungen

  • Neue Themen erstellen: Nein
  • Themen beantworten: Nein
  • Anhänge hochladen: Nein
  • Beiträge bearbeiten: Nein
  •  
Excel Ticker - News, Tipps und Tricks zu Microsoft Excel | SMS kostenlos versenden | Forenuser - Die Foren Findmaschine