Hallo Leute,
ich möchte ( Sepp :-)) sein Script um den oberen in einem Worksheet erweitern und der erste soll bitte Spalte D & E auf doppelte Eingabe prüfen.
Danke für eure Hilfe wie immer Neo
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim name As String
If Intersect(Range("D:D"), Target) Is Nothing Then Exit Sub
name = Target
If WorksheetFunction.CountIf(Range("D:D"), name) > 1 Then
MsgBox name & " schon vergeben !!", vbCritical
End If
End Sub
Dim rng As Range, rngRow As Range, lngN As Long, lngC As Long
If Not Intersect(Target, Range("I2:AF104")) Is Nothing Then
Range("I2:AF104").Interior.ColorIndex = xlNone
For Each rngRow In Range("I2:AF104").Rows
lngC = 44
For Each rng In rngRow.Cells
If rng "" Then
lngC = IIf(lngC = 22, 44, 22)
lngN = replaceLetters(rng.Text)
rng.Resize(1, Application.Max(1, Application.Min(lngN, 33 - rng.Column))).Interior.ColorIndex = lngC
End If
Next
Next
End If
End Sub
Private Function replaceLetters(Text As String) As Long
Dim objRegEx As Object
Set objRegEx = CreateObject("VBScript.RegExp")
On Error Resume Next
With objRegEx
.MultiLine = True
.Global = True
.IgnoreCase = True
.Pattern = "\D+"
replaceLetters = CLng(.Replace(Text, ""))
End With
Set objRegEx = Nothing
End Function