Unterschiedliche Zellbezüge
Chris
unten stehendes Makro bewirkt, dass sich der Wert in Zelle B27 um 1 oder um 0,5 erhöht bzw. verringert - je nachdem welcher Begriff in verschiedenen Zellenbereichen eingeben wird. Läuft soweit ohne Probleme.
Nun möchte ich dasselbe Makro auf weitere Zellen anwenden. Soll heißen:
Wenn man in C67:C74,F67:F74,I67:I74,L67:L74,O67:O74 die Begriffe "Test1" bzw. "Teste2" schreibt, soll sich der Wert in Zelle B66 um 1 oder 0.5 erhöhen.
Von den langen Bereichen (im Beispiel C67:O74) benötige ich insg. 10 verschiedene. Für jeden der 10 verschiedenen großen Bereichen soll sich jeweils der Wert in einer anderen einzelnen Zelle verändern soabdk man Test1 oder Test2 eingibt, also zum Beispiel: Bei C166:O174 und dem Wort test1 soll sich derWert in Zelle B155 ändern usw.
Wenn ich das Makro starte, kommt zwar keine Fehlermeldung, aber der Wert in Zelle B66 ändert sich nicht. Es läuft immer nur das erste Makro für Zelle B27 - Excel ignoriert einfach den zweiten Teil.
Weiss jemand wieso?
Schon mal danke,
Chris
HIer das Makro:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Dim Zelle As Range
Dim BereichIntersect As Range
Dim Zelle1 As Range
Dim BereichIntersect1 As Range
Set BereichIntersect = Intersect(Target, Range("C28:C35,F28:F35,I28:I35,L28:L35,O28:O35") _
)
If BereichIntersect Is Nothing Then
Exit Sub
Else
For Each Zelle In BereichIntersect.Cells
Application.EnableEvents = False
Select Case Zelle.Value
Case Is = "Test1"
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value - _
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value + 0.5
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value = "0.5"
Case Is = "Test2"
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value - _
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value + 0.5
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value = 0.5
Case Is = "------"
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value - _
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value
'Wert aus Tabelle2 löschen
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value = ""
Case Else
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value - _
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value
Worksheets(3).Cells(27, 2).Value = Worksheets(3).Cells(27, 2).Value + 1
Worksheets(5).Cells(Zelle.Row, Zelle.Column).Value = "1"
End Select
Application.EnableEvents = True
Next
End If
Set BereichIntersect1 = Intersect(Target, Range("C67:C74,F67:F74,I67:I74,L67:L74,O67:O74" _
))
If BereichIntersect1 Is Nothing Then
Exit Sub
Else
For Each Zelle1 In BereichIntersect1.Cells
Application.EnableEvents = False
Select Case Zelle1.Value
Case Is = "Test1"
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value - _
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value + 0.5
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value = "0.5"
Case Is = "Test2"
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value - _
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value + 0.5
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value = 0.5
Case Is = "------"
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value - _
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value = ""
Case Else
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value - _
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value
Worksheets(3).Cells(66, 2).Value = Worksheets(3).Cells(66, 2).Value + 1
Worksheets(5).Cells(Zelle1.Row, Zelle1.Column).Value = "1"
End Select
Application.EnableEvents = True
Next
End If
Exit Sub
Fehler: MsgBox Err.Description, vbInformation, "Fehler"
End Sub