Makro nur teilweise ausgeführt
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 eine andere Zelle anwenden (B66) (und noch weitere 10 verschiedene Zellen mit unterschiedliche Bereichen). Ich habe daher das Makro kopiert, die Variablennamen geändert und die Bereiche angepasst.). 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?
Bei der Gelegenheit: Gib es evtl. eine einfachere Möglichkeit, als das Makro 10x zu kopieren und jeweils die Bereich anzupassen?
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