Wenn in Toleranz dann Farbe

Forumthread: Wenn in Toleranz dann Farbe

02.03.2021 08:27:48

Lars

Hallo Community,
ich habe leider noch das Problem, dass ich bei meinem VBA-Programm in Zeile 7 folgenden Fehler bekomme:
Laufzeitfehler '13':
Typen unverträglich
Ich bekomme diesen leider nicht weg. Kann mir einer evtl. sagen wo mein Fehler ist?
Folgendes will ich als Endergebnis:
Wenn in Spalte N eine eine Zahl ist, dann in Spalte A prüfen welche Toleranz gilt und dementsprechend die Zeile einfärben.
Wenn Spalte N leer ist, diese auch leer lassen.
Mit einer bedingten Formatierung komme ich da leider nicht weiter, da ich ca. 10 verschiedene Toleranzbereiche habe (grün, gelb & rot).
Grün kann z.B. ein von -5 bis 5 gehen, mal von -2 bis 2 oder -3 bis 0.
Und wenn in Spalte N eine Zeile leer ist, bleibt die auch nicht unformatiert.
Hier mal eine Beispieldatei:
https://www.herber.de/bbs/user/144362.xlsm
Vielen Dank schonmal im voraus für Eure Hilfe.
Gruß
Lars

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Wenn in Toleranz dann Farbe

02.03.2021 08:55:32

Nepumuk
Nachtrag

02.03.2021 09:01:48

Nepumuk
AW: Nachtrag

02.03.2021 09:38:03

Lars
AW: Nachtrag

02.03.2021 09:51:58

Nepumuk
AW: Nachtrag

02.03.2021 10:00:51

Lars
AW: Nachtrag

02.03.2021 10:07:34

Lars
AW: Nachtrag

02.03.2021 10:08:03

Herbert_Grom
AW: Nachtrag

02.03.2021 10:24:11

Lars
AW: Nachtrag

02.03.2021 10:13:29

Nepumuk
AW: Nachtrag

02.03.2021 10:25:13

Lars

AW: Wenn in Toleranz dann Farbe

02.03.2021 08:55:32

Nepumuk

Hallo Lars,
teste mal:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lngColor1 As Long
    Dim lngColor2 As Long
    Dim objRange As Range, objCell As Range

    Set objRange = Intersect(Target, Range("N11:N40000"))

    If Not objRange Is Nothing Then

        For Each objCell In objRange

            Select Case objCell.Offset(0, -13)

                Case "K123456", "K234567", "K345678", "K456789"

                    If IsNumeric(objCell.Value) Then

                        Select Case objCell.Value

                            Case -5 To 5
                                lngColor1 = vbGreen
                                lngColor2 = vbBlack
                            Case -10 To -6, 6 To 10
                                lngColor1 = vbYellow
                                lngColor2 = vbBlack
                            Case Is < -10, Is > 10
                                lngColor1 = vbRed
                                lngColor2 = vbBlack

                        End Select
                    End If

                Case "K555555", "K555556", "555557", "555558"

                    If IsNumeric(objCell.Value) Then

                        Select Case objCell.Value

                            Case -2 To 2
                                lngColor1 = vbGreen
                                lngColor2 = vbBlack
                            Case -5 To -3, 3 To 5
                                lngColor1 = vbYellow
                                lngColor2 = vbBlack
                            Case Is < -5, Is > 5
                                lngColor1 = vbRed
                                lngColor2 = vbBlack

                        End Select
                    End If
            End Select

            objCell.Interior.Color = lngColor1
            objCell.Font.Color = lngColor2

        Next

        Set objRange = Nothing

    End If
End Sub

Gruß
Nepumuk

Nachtrag

02.03.2021 09:01:48

Nepumuk

Benutze an Stelle von:
If IsNumeric(objCell.Value) Then
besser:
If IsNumeric(objCell.Text) Then
denn die Value-Eigenschaft gibt, wenn die Zelle leer ist, eine 0 zurück.
Gruß
Nepumuk

AW: Nachtrag

02.03.2021 09:38:03

Lars

Hallo Nepumuk,
vielen Dank, das hat mich schonmal ein ganzes Stück weiter gebracht.
Die Toleranzen werden in der entsprechenden Farbe eingefärbt.
Nur wenn in Spalte N nichts steht, dann wird da eine 0 eingefügt und die Zelle wird eingefärbt.
In der Zelle sollte nichts stehen und diese sollte keine Farbe erhalten.
Was ich vergessen habe zu erwähnen:
Es gibt in der Spalte A auch Nummern/Texte (im Beispiel K987654), bei diesen soll in Spalte N nicht eingefärbt werden.
Folgend die geänderte Beispieldatei:
https://www.herber.de/bbs/user/144365.xlsm
Danke & Gruß
Lars

AW: Nachtrag

02.03.2021 09:51:58

Nepumuk

Hallo Lars,
so besser?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim objRange As Range, objCell As Range

    Set objRange = Intersect(Target, Range("N11:N40000"))

    If Not objRange Is Nothing Then

        For Each objCell In objRange

            Select Case objCell.Offset(0, -13)

                Case "K123456", "K234567", "K345678", "K456789"

                    If IsNumeric(objCell.Text) Then

                        Select Case objCell.Value

                            Case -5 To 5
                                objCell.Interior.Color = vbGreen
                                objCell.Font.Color = vbBlack
                            Case -10 To -6, 6 To 10
                                objCell.Interior.Color = vbYellow
                                objCell.Font.Color = vbBlack
                            Case Is < -10, Is > 10
                                objCell.Interior.Color = vbRed
                                objCell.Font.Color = vbBlack
                            Case Else
                                objCell.Interior.Pattern = xlPatternNone

                        End Select
                    Else
                        objCell.Interior.Pattern = xlPatternNone
                    End If

                Case "K555555", "K666666", "K777777", "K888888"

                    If IsNumeric(objCell.Text) Then

                        Select Case objCell.Value

                            Case -2 To 2
                                objCell.Interior.Color = vbGreen
                                objCell.Font.Color = vbBlack
                            Case -5 To -3, 3 To 5
                                objCell.Interior.Color = vbYellow
                                objCell.Font.Color = vbBlack
                            Case Is < -5, Is > 5
                                objCell.Interior.Color = vbRed
                                objCell.Font.Color = vbBlack
                            Case Else
                                objCell.Interior.Pattern = xlPatternNone

                        End Select
                    Else
                        objCell.Interior.Pattern = xlPatternNone
                    End If
            End Select
        Next

        Set objRange = Nothing

    End If
End Sub

Gruß
Nepumuk

AW: Nachtrag

02.03.2021 10:00:51

Lars

Hallo Nepumuk,
vielen Dank für deine schnellen Rückmeldungen.
Aber leider nein.
Das Programm färbt mir bei K987654 und bei leeren Zellen, die Zelle gelb.
Gruß
Lars

AW: Nachtrag

02.03.2021 10:07:34

Lars

Hallo Nepumuk,
anbei noch die Beispieldatei:
https://www.herber.de/bbs/user/144366.xlsm
Gruß
Lars

AW: Nachtrag

02.03.2021 10:08:03

Herbert_Grom

Hallo Lars,
probiers mal damit:
https://www.herber.de/bbs/user/144367.xlsm
Ist auf Nepumuks Code aufgebaut!
Servus

AW: Nachtrag

02.03.2021 10:24:11

Lars

Hallo Herbert_Grom,
Vielen Dank für deine Rückmeldung.
Bei deinem Code löscht er mir leider in Spalte N alles raus, was nicht zu den genannten Bedingungen (Spalte A) gehört.
Nepumuk hat mir parallel zu dir noch einen geschickt, welcher super funktioniert.
Trotzdem vielen Dank.
Gruß
Lars

AW: Nachtrag

02.03.2021 10:13:29

Nepumuk

Hallo Lars,
jetzt immer noch?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim objRange As Range, objCell As Range

    Set objRange = Intersect(Target, Range("N11:N40000"))

    If Not objRange Is Nothing Then

        For Each objCell In objRange

            Select Case objCell.Offset(0, -13).Value

                Case "K123456", "K234567", "K345678", "K456789"

                    If IsNumeric(objCell.Text) Then

                        Select Case objCell.Value

                            Case -5 To 5
                                objCell.Interior.Color = vbGreen
                                objCell.Font.Color = vbBlack
                            Case -10 To -6, 6 To 10
                                objCell.Interior.Color = vbYellow
                                objCell.Font.Color = vbBlack
                            Case Is < -10, Is > 10
                                objCell.Interior.Color = vbRed
                                objCell.Font.Color = vbBlack
                            Case Else
                                objCell.Interior.Pattern = xlPatternNone

                        End Select
                    Else
                        objCell.Interior.Pattern = xlPatternNone
                    End If

                Case "K555555", "K666666", "K777777", "K888888"

                    If IsNumeric(objCell.Text) Then

                        Select Case objCell.Value

                            Case -2 To 2
                                objCell.Interior.Color = vbGreen
                                objCell.Font.Color = vbBlack
                            Case -5 To -3, 3 To 5
                                objCell.Interior.Color = vbYellow
                                objCell.Font.Color = vbBlack
                            Case Is < -5, Is > 5
                                objCell.Interior.Color = vbRed
                                objCell.Font.Color = vbBlack
                            Case Else
                                objCell.Interior.Pattern = xlPatternNone

                        End Select
                    Else
                        objCell.Interior.Pattern = xlPatternNone
                    End If
                Case Else
                    objCell.Interior.Pattern = xlPatternNone
            End Select
        Next

        Set objRange = Nothing

    End If
End Sub

Gruß
Nepumuk

AW: Nachtrag

02.03.2021 10:25:13

Lars

Hallo Nepumuk,
jetzt funktioniert alles Einwandfrei.
Vielen Dank für die schnelle Hilfe.
Ich wünsche noch einen schönen Tag.
Gruß und vielen vielen Dank
Lars

Beliebteste Forumthreads (12 Monate)

Forumthread: Wenn in Toleranz dann Farbe

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread