zwei subs in Arbeitsmappe

Question

Hallo,

ich möchte gerne zwei Subs

einmal: zum ändern der Farbe der Zelle

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim bereich, Zelle As Range
Set bereich = Range("B3:AF29")
For Each Zelle In bereich

Select Case Target.Value
Case "HO", "ho", "Ho"
Target.Interior.Color = RGB(255, 87, 87)
Case "OP", "Op,", "op"
Target.Interior.Color = RGB(97, 214, 255)
Case "EU", "Eu", "eu"
Target.Interior.Color = RGB(105, 255, 105)
Case "RU", "Ru", "ru"
Target.Interior.Color = RGB(0, 205, 0)
Case Else
Target.Interior.ColorIndex = 2
End Select
Next
End Sub


Und den anderen: das die Buchstaben automatisch groß geschrieben werden

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo fehler
If Not Intersect(Target, Range("C12, C13, C14,C16")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
End If
fehler:
Application.EnableEvents = True
End Sub


auf die gesamte Arbeitsmappe anwenden, doch wenn ich beide einfüge , kommt die Fehlermeldung:

Fehler beim Kompilieren
Mehrdeutiger Name: Worksheet_Change

Was muss ich ändern?

Answer 1

Entschuldigt hatte den noch nicht angepassten Code für die Großschreibung genommen. Habe den Namen des Subs und die Range schon angepasst, geht aber trotzdem nicht.

Vielen Dank schon mal für eure Hilfe!

Answer 2

Hallo,

du kannst nicht zwei Worksheet_Change-Subs in einer Mappe haben. Du musst die beiden Codes zusammenfassen. Also etwa so (ungetestet):

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim bereich, Zelle As Range
Set bereich = Range("B3:AF29")

On Error GoTo fehler
If Not Intersect(Target, Range("C12, C13, C14,C16")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
End If
fehler:
Application.EnableEvents = True

For Each Zelle In bereich

Select Case Target.Value
Case "HO", "ho", "Ho"
Target.Interior.Color = RGB(255, 87, 87)
Case "OP", "Op,", "op"
Target.Interior.Color = RGB(97, 214, 255)
Case "EU", "Eu", "eu"
Target.Interior.Color = RGB(105, 255, 105)
Case "RU", "Ru", "ru"
Target.Interior.Color = RGB(0, 205, 0)
Case Else
Target.Interior.ColorIndex = 2
End Select
Next

End Sub

Gruß

M.O.

Answer 3

Hallo,

okay habe verstanden, dein Vorschlag, hat leider nicht funktioniert, aber werde ein bisschen herumprobieren, vlt. finde ich ja ne Lösung.

Aber habe noch eine Frage, wenn ich in eine Zeile z.B. "HO" eintrage und die Zelle mittels dem kleinem Rechteck, was sich immer rechts unten in jeder Zelle befindet, kopiere kommt der Laufzeitfehler '13: Typen Unverträglich.

Liegt das daran, dass der Code keine Schleife ist oder woran liegt das?

Vielen Dank und grüße

Simonski

Answer 4

Hallo,

die Fehlermeldung kommt daher, dass du in der Select-Case-Anweisung mit Target arbeitest. Wenn du durch das Ziehen mehrere Zellen selektierst, klappt die Abfrage des Wertes nicht mehr.

Probier mal das folgende Makro aus, mit dem auch das Ziehen der Zellen klappen sollte:

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim bereich, Zelle As Range
Set bereich = Range("B3:AF29")

On Error GoTo fehler
If Not Intersect(Target, Range("C12, C13, C14,C16")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
End If
fehler:
Application.EnableEvents = True


For Each Zelle In Target

If Not Intersect(Zelle, bereich) Is Nothing Then
'Prüfen ob Zelladresse im definierten Bereich liegt
If Intersect(Zelle, bereich).Address = Zelle.Address Then
'falls ja, dann Hintergrundfarbe der Zelle festlegen
Select Case Zelle.Value
Case "HO", "ho", "Ho"
Zelle.Interior.Color = RGB(255, 87, 87)
Case "OP", "Op,", "op"
Zelle.Interior.Color = RGB(97, 214, 255)
Case "EU", "Eu", "eu"
Zelle.Interior.Color = RGB(105, 255, 105)
Case "RU", "Ru", "ru"
Zelle.Interior.Color = RGB(0, 205, 0)
Case Else
Zelle.Interior.ColorIndex = 2
End Select

End If

Else
'falls nein, dann keine Hintergrundfarbe (bzw. weiß)
Zelle.Interior.Color = RGB(255, 255, 255)

End If

Next Zelle

End Sub

Gruß

M.O.