Office: zwei funktionierende Private Sub Worksheet_Change zusammen

Hey,
habe ein riesen Problem habe zwei funktionierende Private Sub Worksheet_Change geschrieben, leider greifen sie aber beide auf die gleiche Tabelle zu. Es wird immer nur das aufgeführt was als erstes steht.

Der erste code sieht so aus

Private Sub Worksheet_Change(ByVal Target As Range)


If Intersect(Target, Range("H2:H1000")) Is Nothing Then Exit Sub
If InStr(1, Cells(Target.Row, 8), "Ja", 1) 0 Then
Cells(Target.Row, 9).Validation.Delete
Cells(Target.Row, 9) = "bekommen"
Else
If Cells(Target.Row, 9) = "bekommen" Then Cells(Target.Row, 9) = ""
ActiveWorkbook.Names.Add Name:="Guelt", RefersTo:="=Tabelle3!$C$2:$C$4"
Cells(Target.Row, 9).Validation.Delet
Cells(Target.Row, 9).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Guelt"
End If




End Sub


und der zweite so

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range
Dim bytColor As Byte
Dim a As Range
' Bereich der überwacht wird
Set Target = Intersect(Target, Range("I2:I65000"))
If Target Is Nothing Then Exit Sub

For Each rngCell In Target
Select Case rngCell.Value
Case "verloren"
bytColor = 3 ' Rot
Case "bekommen"
bytColor = 4 ' Grün

Case "läuft"
bytColor = 6 ' Gelb

Case Else
bytColor = 0 ' keine Farbe
End Select

Range("I" & (Target.Row), Cells(Target.Row, 9)).Interior.ColorIndex = bytColor
Next rngCell
End Sub


wäre lieb wenn mir eine hilft.

mfg

Tanja

:)

 

Hallo,

so:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range
Dim bytColor As Byte

If Not Intersect(Target, Range("H2:H1000")) Is Nothing Then
If InStr(1, Cells(Target.Row, 8), "Ja", 1) <> 0 Then
Cells(Target.Row, 9).Validation.Delete
Cells(Target.Row, 9) = "bekommen"
Else
If Cells(Target.Row, 9) = "bekommen" Then Cells(Target.Row, 9) = ""
ActiveWorkbook.Names.Add Name:="Guelt", RefersTo:="=Tabelle3!$C$2:$C$4"
Cells(Target.Row, 9).Validation.Delet
Cells(Target.Row, 9).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Guelt"
End If
End If

' Bereich der überwacht wird
Set Target = Intersect(Target, Range("I2:I65000"))
If Not Target Is Nothing Then
For Each rngCell In Target
Select Case rngCell.Value
Case "verloren"
bytColor = 3 ' Rot
Case "bekommen"
bytColor = 4 ' Grün
Case "läuft"
bytColor = 6 ' Gelb
Case Else
bytColor = 0 ' keine Farbe
End Select
Range("I" & (Target.Row), Cells(Target.Row, 9)).Interior.ColorIndex = bytColor
Next rngCell
End If
End Sub

 

Hey,

es klappt vielen Dank.

lg grüße

Tanja

 

Hey mein gesamter code für ein Tabellen blatt sieht bisher so aus

Code:

das Problem ist jetzt nur das wenn ich eine gesamte zeile makiere wird die gesamte Zeile gelöscht. was ja nicht sinn der Sache ist.

Lg Tanja