Sub Blau()
Dim Spa As Long
Range("F5:AH5").Font.ColorIndex = 0
For Spa = 6 To 34
If Application.CountIf(Range("F5:AH5"), Cells(5, Spa).Value) > 1 Then
Cells(5, Spa).Font.ColorIndex = 5
End If
Next Spa
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Spa As Long
If UCase(Range("H1")) = "X" Then Exit Sub
Range("F5:AH5").Font.ColorIndex = 0
For Spa = 6 To 34
If Application.CountIf(Range("F5:AH5"), Cells(5, Spa).Value) > 1 Then
Cells(5, Spa).Font.ColorIndex = 5
End If
Next Spa
Range("F6:AH6").Font.ColorIndex = 0
For Spa = 6 To 34
If Application.CountIf(Range("F6:AH6"), Cells(5, Spa).Value) > 1 Then
Cells(5, Spa).Font.ColorIndex = 5
End If
Next Spa
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Zelle As Range
If UCase(Range("H1")) = "X" Then Exit Sub
Range("F5:AH6").Font.ColorIndex = 0
For Each Zelle In Range("F5:AH6")
If Application.CountIf(Range("F5:AH6"), Zelle.Value) > 1 Then
Zelle.Font.ColorIndex = 5
End If
Next Zelle
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Spa As Long
If UCase(Range("H1")) = "X" Then Exit Sub
Range("F5:AH6").Font.ColorIndex = 0
For Spa = 6 To 34
If Application.CountIf(Range("F5:AH5"), Cells(5, Spa).Value) > 1 Then
Cells(5, Spa).Font.ColorIndex = 5
End If
Next Spa
For Spa = 6 To 34
If Application.CountIf(Range("F6:AH6"), Cells(6, Spa).Value) > 1 Then
Cells(6, Spa).Font.ColorIndex = 5
End If
Next Spa
End Sub
Die Datei https://www.herber.de/bbs/user/77308.xls wurde aus Datenschutzgründen gelöscht
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zei As Long, Spa As Long
If UCase(Range("H1")) = "X" Then Exit Sub
If Intersect(Target, Range("F5:AH40")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
Zei = Target.Row
Range("F" & Zei & ":AH" & Zei).Font.ColorIndex = 0
For Spa = 6 To 34
If Application.CountIf(Range("F" & Zei & ":AH" & Zei), Cells(Zei, Spa).Value) > 1 Then
Cells(Zei, Spa).Font.ColorIndex = 5
End If
Next Spa
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub faerben()
Dim objsh As Worksheet
Dim rng As Range
On Error GoTo ErrExit
tranquilize
Set objsh = Worksheets.Add
With Sheets("Tabelle2").Range("F5:AH40") 'Anpassen!
.Interior.ColorIndex = xlNone
objsh.Range(.Address).Formula = "=IF(COUNTIF('" & .Parent.Name & "'!" & _
.Rows(1).Address(0, 1) & ",'" & .Parent.Name & "'!" & _
.Cells(1, 1).Address(0, 0) & ")>1,1,""X"")"
On Error Resume Next
Set rng = objsh.Range(.Address).SpecialCells(xlCellTypeFormulas, xlNumbers)
On Error GoTo ErrExit
If Not rng Is Nothing Then
rng.Interior.ColorIndex = 33
objsh.Range(.Address).Copy
.Cells(1, 1).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.Goto .Cells(1, 1)
End With
objsh.Delete
ErrExit:
tranquilize True
Set rng = Nothing
Set objsh = Nothing
End Sub
Public Sub tranquilize(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
If Modus Then
With Err
If .Number <> 0 Then
MsgBox IIf(Erl, vbLf & "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbLf & _
.Description, vbExclamation, "Fehler"
End If
.Clear
End With
End If
End Sub