Hey Harald
Super mal wieder was von Dir zu hören !!
Hier der Original Code.
Hoffe Du kannst mir Bitte weiterhelfen !!
Gruß Heinz
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngRow As Long
If Target.Column > 5 Then Exit Sub
lngRow = Target.Row ' diese Zeile aktivieren Wenn nur die Aktuell geänderte Zeile neu berechnet _
werden soll
' For lngRow = 2 to 100 ' diese Zeile und die "Next" Zeile ganz unten im Code aktivieren wenn _
die Zeilen 2 bis 100 bei jeder Änderung neu Berechnet werden sollen
' Zählen Wenn in Aktiver Zeile Spalte A bis Spalte E der Eintrag 1U, 1K, 1BF vorkommt
U1 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "1U")
U2 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "1K")
U3 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "1BF")
' Zählen Wenn in Aktiver Zeile Spalte A bis Spalte E der Eintrag 2U, 2K, 2BF vorkommt
V1 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "2U")
V2 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "2K")
V3 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "2BF")
' Zählen Wenn in Aktiver Zeile Spalte A bis Spalte E der Eintrag 3U, 3K, 3BF vorkommt
W1 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "3U")
W2 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "3K")
W3 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "3BF")
' Zählen Wenn in Aktiver Zeile Spalte A bis Spalte E der Eintrag 1, 1Ü, 1B vorkommt
X1 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "1")
X2 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "1Ü")
X3 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "1B")
' Zählen Wenn in Aktiver Zeile Spalte A bis Spalte E der Eintrag 2, 2Ü, 2B vorkommt
Y1 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "2")
Y2 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "2Ü")
Y3 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "2B")
' Zählen Wenn in Aktiver Zeile Spalte A bis Spalte E der Eintrag 3, 3Ü, 3B vorkommt
Z1 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "3")
Z2 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "3Ü")
Z3 = WorksheetFunction.CountIf(Range(Cells(lngRow, 1), Cells(lngRow, 5)), "3B")
If Cells(lngRow, 6) = "" Then ' Wenn Wert in Zelle dann nix Schreiben
' Eintrag 1 in Spalte 6 wenn In Aktiver Zeile 1U, 1K, 1BF steht und 1, 1Ü, 1B fehlt
If U1 + U2 + U3 > 0 And X1 + X2 + X3 = 0 Then Cells(lngRow, 6) = 1
If U1 + U2 + U3 = 0 And X1 + X2 + X3 = 0 Then Cells(lngRow, 6) = 1
' Eintrag 2 in Spalte 6 wenn In Aktiver Zeile 2U, 2K, 2BF steht und 2, 2Ü, 2B fehlt
If V1 + V2 + V3 > 0 And Y1 + Y2 + Y3 = 0 Then Cells(lngRow, 6) = 2
If V1 + V2 + V3 = 0 And Y1 + Y2 + Y3 = 0 Then Cells(lngRow, 6) = 2
' Eintrag 3 in Spalte 6 wenn In Aktiver Zeile 3U, 3K, 3BF steht und 3, 3Ü, 3B fehlt
If W1 + W2 + W3 > 0 And Z1 + Z2 + Z3 = 0 Then Cells(lngRow, 6) = 3
If W1 + W2 + W3 = 0 And Z1 + Z2 + Z3 = 0 Then Cells(lngRow, 6) = 3
End If ' Ende wenn Wert in Zelle nix Schreiben
' Next lngRow
End Sub