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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen