Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1184to1188
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

doppelte Eingabe per VBA prüfen

doppelte Eingabe per VBA prüfen
neonac

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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: doppelte Eingabe per VBA prüfen
15.11.2010 17:25:19
fcs
Hallo Neo,
was meinst du mit
soll bitte Spalte D & E auf doppelte Eingabe prüfen.
A: Getrennte Auswertung auf doppelte in Spalten D und E?
B: Die Kombination der Werte in Spalten D und E soll auf doppelte geprüft werden?
Gruß
Franz
AW: doppelte Eingabe per VBA prüfen
17.11.2010 23:45:27
Neo
Hallo Franz,
das obere VBA Script sagt wenn ich in Spalte D einen Wert doppelt eingebe "schon vorhanden" und das soll auch in Spalte E passieren. Dieses Script soll dann noch an das andere anepasst werden so das beide in einem Worksheet arbeiten wenn das geht ?
Danke & Grüße Neo
AW: doppelte Eingabe per VBA prüfen
18.11.2010 00:30:29
fcs
Hallo Neo,
mit folgenden Anpassungen sollte es funktionieren.
Gruß
Franz

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rng As Range, rngRow As Range, lngN As Long, lngC As Long
Dim name As String
If Not Intersect(Range("D:D"), Target) Is Nothing Then
For Each rng In Target
Call CheckDoppelte(rng, 4)
Next
ElseIf Not Intersect(Range("E:E"), Target) Is Nothing Then
For Each rng In Target
Call CheckDoppelte(rng, 5)
Next
ElseIf 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 CheckDoppelte(rngZelle As Range, lSpalte As Long)
If rngZelle.Value  "" And rngZelle.Column = lSpalte Then
If WorksheetFunction.CountIf(Columns(lSpalte), rngZelle.Value) > 1 Then
MsgBox rngZelle.Value & " schon vergeben !!", vbCritical
Application.EnableEvents = False
rngZelle.Clear
Application.EnableEvents = True
rngZelle.Select
End If
End If
End Function
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

Anzeige
AW: doppelte Eingabe per VBA prüfen
18.11.2010 23:12:34
Neo
Hallo Franz,
geht perfekt, Danke wie immer für die Hilfe.
Grüße Neo

147 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige