Hallo.

Ich habe vom Kollegen (der leider ausgeschieden ist) eine Excel Tabelle (aktuelle Version) mit einem VBA-Script übernommen. Das Script soll die 3 niedrigsten Preise einer Matrix farblich markieren, und zwar nach einem aufsteigenden Prinzip (den kleinsten Preis "grün" dann "gelb" und anschl. "rot").

Es sind 4 verschiedene Bereiche, welche alle gleich aussehen. Die Zahlen in "schwarz" sind Grundpreise, welche nicht beachtet werden sollen. Nur die Zahlen in "blau" sollen verglichen werden. Diese ergeben sich aus Addition des Grundwertes und verschiedener zusätzlicher Werte. Jeden Monat ändern sich die "blauen" Werte und sind somit immer unterschiedlich. Die erste Zelle (Zahl 585,00 €) in der u.a. Tabelle ist F10. Hier ein Beispiel.

Im Objekt ist folgender Code hinterlegt:

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Call the ApplyHighlightCode subroutine with the Target argument to update highlights
    ApplyHighlightCode Target
End Sub
Private Sub Workbook_Open()
    Application.EnableEvents = True
End Sub

Als Module folgender Code:

' Module1 - This is a public module
Sub ApplyCodeToWorksheets()
    ' Apply the code to the "Test" worksheet
    ApplyHighlightCode ThisWorkbook.Sheets("Test").Range("A1")

    ' Add more worksheets as needed
    ' ApplyHighlightCode ThisWorkbook.Sheets("AnotherWorksheet").Range("A1")
End Sub

Sub ApplyHighlightCode(Target As Range)
    ' Extract the worksheet from the Target range
    Dim ws As Worksheet
    Set ws = Target.Worksheet

    ' Define the ranges for each worksheet
    Dim rng1 As String, rng2 As String, rng3 As String, rng4 As String

    ' Define the ranges for the specific worksheet
    Select Case ws.Name
    
        Case "Test"
            rng1 = "F10:AC43"
            rng2 = "F55:AC88"
            rng3 = "AJ10:BE43"
            rng4 = "AJ55:BE88"
       
        ' Add more cases for other worksheets as needed
    End Select

    ' Define the union of ranges
    Dim rng As Range
    Set rng = Union(ws.Range(rng1), ws.Range(rng2), ws.Range(rng3), ws.Range(rng4))

    Application.ScreenUpdating = False ' Disable screen updating for faster execution

    ' Clear previous highlights
    rng.Interior.ColorIndex = xlNone

    For Each Row In rng.Rows
        ' Initialize variables to keep track of the lowest, second lowest, and third lowest values for the current row
        lowestValue = 0
        secondLowestValue = 0
        thirdLowestValue = 0

        ' Initialize variables to keep track of the cells containing the lowest, second lowest, and third lowest values
        Set lowestCell = Nothing
        Set secondLowestCell = Nothing
        Set thirdLowestCell = Nothing

        ' Populate the array with row values
        valuesArray = Row.Value

        ' Loop through each cell in the current row
        For j = 1 To UBound(valuesArray, 2)
            ' Get the entire column name (e.g., "F", "G", "AH")
            Dim columnName As String
            columnName = Split(Row.Cells(1, j).Address, "$")(1)

            ' Check if the entire column name is in the list of excluded columns
            If Not IsExcludedColumn(columnName) Then
                ' Check if the value is numeric and greater than 1
                If IsNumeric(valuesArray(1, j)) And valuesArray(1, j) > 1 Then
                    ' Compare the value to the current lowest, second lowest, and third lowest values
                    If valuesArray(1, j) < lowestValue Or lowestValue = 0 Then
                        thirdLowestValue = secondLowestValue
                        Set thirdLowestCell = secondLowestCell
                        secondLowestValue = lowestValue
                        Set secondLowestCell = lowestCell
                        lowestValue = valuesArray(1, j)
                        Set lowestCell = Row.Cells(1, j)
                    ElseIf valuesArray(1, j) < secondLowestValue Or secondLowestValue = 0 Then
                        thirdLowestValue = secondLowestValue
                        Set thirdLowestCell = secondLowestCell
                        secondLowestValue = valuesArray(1, j)
                        Set secondLowestCell = Row.Cells(1, j)
                    ElseIf valuesArray(1, j) < thirdLowestValue Or thirdLowestValue = 0 Then
                        thirdLowestValue = valuesArray(1, j)
                        Set thirdLowestCell = Row.Cells(1, j)
                    End If
                End If
            End If
        Next j

        ' Apply formatting to the cells with the lowest, second lowest, and third lowest values
        If Not lowestCell Is Nothing Then lowestCell.Interior.Color = RGB(147, 237, 135) ' Red
        If Not secondLowestCell Is Nothing Then secondLowestCell.Interior.Color = RGB(255, 255, 0) ' Yellow
        If Not thirdLowestCell Is Nothing Then thirdLowestCell.Interior.Color = RGB(252, 192, 200) ' Green
    Next Row

    Application.ScreenUpdating = True ' Re-enable screen updating
End Sub

' Function to check if a column should be excluded
Function IsExcludedColumn(columnName As String) As Boolean
    Dim excludedColumns As String
    excludedColumns = "F,H,J,L,N,P,R,T,V,X,Z,AB,AD,AE,AF,AG,AH,AI,AJ,AL,AN,AP,AR,AT,AV,AX,AZ,BB,BD,BF,BH,BJ"

    ' Check if the columnName is in the list of excluded columns
    IsExcludedColumn = InStr(1, excludedColumns, columnName, vbTextCompare) > 0
End Function

Seit dem die Tabelle etwas ergänzt wurde, funktioniert das Script nicht mehr richtig.

Beim Ausführen des Scriptes kommt ein Fehler und beim debbugen wir in folgender Zeile

 If IsNumeric(valuesArray(1, j)) And valuesArray(1, j) > 1 Then

der Fehler angezeigt:

valuesArray(1, j) = Fehler 2015

Ich hoffe, ich habe alles Nötige geschildert. Falls noch etwas gebraucht wird, bitte fragen.

Hat vielleicht jemand eine Idee.

Vielen Dank für die Hilfe.

VG

Johnny