Anzeige
Archiv - Navigation
820to824
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
820to824
820to824
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Duplikate melden zeilenweise

Duplikate melden zeilenweise
20.11.2006 22:07:36
Dirk N.
Hallo allen "Mainzelmännchen",
mit Hilfe dieses Forums ist mir die Entwicklung einer fast perfekten, userfreundlichen Datei gelungen.
Es fehlt nur noch ein Baustein u. dann sollte sie perfekt sein... (zumindest aus meiner Sicht ;-) )
Leider konnte ich diesbezüglich nix Passendes im Archiv finden.
Problemstellung
1. Es soll nur in dem Bereich D6:J36 zeilenweise nach Duplikaten gesucht werden. Besondere Betonung liegt hierbei auf zeilenweise - spaltenweise Duplikate sollen erlaubt bleiben.
2. Nur Texteingaben prüfen u. melden, doppelte Eingaben von Zahlen soll erlaubt bleiben.
3.Per MsgBox sollten Duplikate bei der laufenden Eingabe gemeldet werden - dabei reicht lediglich ein Warnhinweis (also ohne Hinweis auf die Zelle, wo bereits ein derartiger Text steht).
Hat jemand von euch eine zündende Idee zur Realisierung?
MfG Dirk N.

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Duplikate melden zeilenweise
20.11.2006 22:24:57
Kurt Isane
Hi,
Textkonstanten oder Textformeln oder beides?
mfg Kurt
AW: Duplikate melden zeilenweise
20.11.2006 22:31:34
Dirk N.
Hallo Kurt,
"Textkonstanten oder Textformeln oder beides?"
Leider kenne ich diesen Unterschied nicht:
Es kann per Doppelklick ein kl. "x" bzw. in einer anderen Spalte per Gültigkeits-Dropdown ein Text eingefügt werden.
Helfen dir diese Angaben weiter?
MfG Dirk N.
AW: Duplikate melden zeilenweise
20.11.2006 22:31:52
EtoPHG
Hallo Dirk,
Was ist ein zeilenweises Duplikat? Mehrere gleiche Einträge in der gleichen Zeile? oder meherer gleiche Einträge in verschiedenen Zeilen ?
Gruss Hansueli
Anzeige
AW: Duplikate melden zeilenweise
20.11.2006 22:51:54
Dirk N.
Hallo Hansueli,
"Mehrere gleiche Einträge in der gleichen Zeile?" Und dies NUR für den genannten Bereich.
Bitte entschuldige meine mißverständliche Angabe, aber genau das meine ich.
MfG Dirk N.
AW: Duplikate melden zeilenweise
20.11.2006 23:25:49
K.Rola
Hallo,
schau mal, ob es passt:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Long
If Not Intersect(Target, [d6:j36]) Is Nothing Then
If Not IsNumeric(Target) Then
r = Target.Row
If Application.CountIf(Range("D" & r & ":J" & r), Target) > 1 Then
MsgBox "Doppelt!"
'Wenn es rückgängig gemacht werden soll
'Application.Undo
End If
End If
End If
End Sub

Gruß K.Rola

Der Fleiß ist die Wurzel aller Häßlichkeit.

Oscar Wilde


Anzeige
AW: Duplikate melden zeilenweise
20.11.2006 23:49:38
Dirk N.
Hi K.Rola,
dein Code funktioniert prima bei der Meldung von Duplikaten aus den Gültigkeits-DropDowns (also der Texteingabe).
Allerdings füge ich mit dem u.g. Code jeweils ein "x" ein u. da versagt die Prüfung u. entspr. Meldung per MsgBox leider:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D6:D36,H6:H36")) Is Nothing Then
Target = IIf(Target = "x", "", "x")
Cancel = True
End If
End Sub

Hast du vllt. noch einen Tipp, was angepasst werden müßte?
MfG Dirk N.
Anzeige
AW: Duplikate melden zeilenweise
20.11.2006 23:54:45
Dirk N.
Hallo K.Rola,
zum besseren Verständnis hier noch der Code - bereits teilweise angepasst mit deinem Tipp:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, rngF As Range
Dim r As Long
'Hintergrundfarbe und Schriftstil (Fett/Kursiv) aus der Namensliste in "Stamm" übernehmen
If Not Intersect(Target, Range("E6:E36,I6:I36")) Is Nothing Then
Me.Unprotect
On Error Resume Next
GetMoreSpeed
For Each rng In Target
If rng = "" Then
rng.Interior.ColorIndex = IIf(rng.Offset(0, -2) = 0, xlNone, 36)
Else
Set rngF = Sheets("Stamm").Range("Namen").Find(rng)
If Not rngF Is Nothing Then
rng.Interior.ColorIndex = IIf(rngF.Interior.ColorIndex <> 55, rngF.Interior.ColorIndex, 36)
rng.Font.Bold = rngF.Font.Bold
rng.Font.Italic = rngF.Font.Italic
End If
Set rngF = Nothing
End If
If Not Intersect(Target, [d6:j36]) Is Nothing Then
If Not IsNumeric(Target) Then
r = Target.Row
If Application.CountIf(Range("D" & r & ":J" & r), Target) > 1 Then
MsgBox "Doppelt!"
'Wenn es rückgängig gemacht werden soll
'Application.Undo
End If
End If
End If
Next
GetMoreSpeed 0
On Error GoTo 0
Me.Protect
End If
End Sub

'' AB HIER versagt leider die weitergehende Prüfung auf Duplikate:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D6:D36,H6:H36")) Is Nothing Then
Target = IIf(Target = "x", "", "x")
Cancel = True
End If
End Sub

MfG Dirk N.
Anzeige
AW: Duplikate melden zeilenweise
21.11.2006 00:01:42
K.Rola
Hallo,
schon klar, weil das Doppelklick-Ereignis erst nach dem Change-Ereignis auftritt.
Ich mach erstmal Schluss für heute, wenn du dich bis morgen gedulden kannst, kümmer
ich mich dann darum.
Gruß K.Rola
AW: Duplikate melden zeilenweise
21.11.2006 00:08:10
Dirk N.
@K.Rola
Natürlich kann ich mich gedulden - gar keine Frage - für mich ist auch gleich Feierabend.
Ich wünsche dir eine gute Nacht u. freue mich auf deinen nächsten Tipp.
MfG Dirk N.
AW: Duplikate melden zeilenweise
21.11.2006 16:48:05
K.Rola
Hallo,
Option Explicit
Dim bolNoChange As Boolean
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D6:D36,H6:H36")) Is Nothing Then
bolNoChange = True
Target = IIf(Target = "x", "", "x")
Cancel = True
Call Machs(Target.Address, False)
bolNoChange = False
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not bolNoChange Then
Call Machs(Target.Address, True)
End If
End Sub
Sub Machs(t As String, bolUndo As Boolean)
Dim r As Long
Dim Ta As Range
Set Ta = Range(t)
If Not Intersect(Ta, [d6:j36]) Is Nothing Then
If Not IsNumeric(Ta) Then
r = Ta.Row
If Application.CountIf(Range("D" & r & ":J" & r), Ta.Text) > 1 Then
MsgBox "Doppelt!"
'Wenn es rückgängig gemacht werden soll
'Das funktioniert aber nur für das Change-Ereignis
'        If bolUndo Then
'           Application.Undo
'        End If
End If
End If
End If
End Sub
Gruß K.Rola

Anzeige
AW: Duplikate melden zeilenweise
21.11.2006 19:54:38
Dirk N.
Hallo K.Rola,
vielen Dank dafür, daß du nochmal draufgeschaut hast.
Habe deinen Code übertragen u. alles funktioniert wunderbar - SUPER !!!
Dann hatte ich allerdings "Blut geleckt" u. versucht, deine geniale Idee bezüglich:
'Wenn es rückgängig gemacht werden soll
'Das funktioniert aber nur für das Change-Ereignis
' If bolUndo Then
' Application.Undo
' End If

noch zum Laufen zu bekommen. Bin aber kläglich gescheitert...
Wenn du noch Lust u. Zeit hast UND es überhaupt eine Lösung zu diesem Anliegen gibt, sende ich dir gern den kompletten Blattcode.
Da ich mit der jetzigen Lösung schon total zufrieden bin, wäre dies lediglich das sogenannte i-Tüpfelchen u. ich möchte deine Hilfsbereitschaft nicht überstrapazieren.
Egal wie du dich entscheidest - tausend Dank für deine Hilfe !!!
MfG Dirk N.
Anzeige
AW: Duplikate melden zeilenweise
21.11.2006 20:21:02
K.Rola
Hallo,
so wird in beiden Fällen der doppelte Eintrag entfernt:
Option Explicit
Dim bolNoChange As Boolean
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D6:D36,H6:H36")) Is Nothing Then
bolNoChange = True
Target = IIf(Target = "x", "", "x")
Cancel = True
Call Machs(Target.Address, False)
bolNoChange = False
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not bolNoChange Then
Call Machs(Target.Address, True)
End If
End Sub
Sub Machs(t As String, bolUndo As Boolean)
Dim r As Long
Dim Ta As Range
Set Ta = Range(t)
If Not Intersect(Ta, [d6:j36]) Is Nothing Then
If Not IsNumeric(Ta) Then
r = Ta.Row
If Application.CountIf(Range("D" & r & ":J" & r), Ta.Text) > 1 Then
MsgBox "Doppelt!"
If bolUndo Then
Application.Undo
Else
Ta.ClearContents
End If
End If
End If
End If
End Sub
Gruß K.Rola

Anzeige
AW: Duplikate melden zeilenweise
21.11.2006 22:18:46
Dirk N.
Hallo K.Rola,
leider gelingt es mir nicht, deinen vorherigen Tipp umzusetzen.
Es erscheint die Fehlermeldung: Laufzeitfehler 1004 Die Methode 'Undo' für das Objekt '_Application' ist fehlgeschlagen.
Der Fehler liegt eindeutig bei mir, denn in einem neuen Blatt funktioniert dein Tipp tadellos.
Ich würde mich freuen, wenn du nochmal auf meinen Originalcode schauen könntest:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.MoveAfterReturnDirection = xlDown
End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim bolNoChange As Boolean
If Not Intersect(Target, Range("D6:D36,H6:H36")) Is Nothing Then
bolNoChange = True
Target = IIf(Target = "x", "", "x")
Cancel = True
'    Call Machs(Target.Address, False)
bolNoChange = False
End If
End Sub

Sub Machs(t As String, bolUndo As Boolean)
Dim r As Long
Dim Ta As Range
Set Ta = Range(t)
If Not Intersect(Ta, [d6:j36]) Is Nothing Then
If Not IsNumeric(Ta) Then
r = Ta.Row
If Application.CountIf(Range("D" & r & ":J" & r), Ta.Text) > 1 Then
MsgBox "Doppelt!"
'Die nachfolgenden Zeilen bis End If hatte ich vorher auskommentiert und nun um deinen letzten Tipp erweitert
If bolUndo Then
Application.Undo
Else
Ta.ClearContents
End If
End If
End If
End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, rngF As Range
If Not bolNoChange Then
Call Machs(Target.Address, True)
End If
'Hintergrundfarbe und Schriftstil (Fett/Kursiv) aus der Namensliste in "Stamm" übernehmen
If Not Intersect(Target, Range("E6:E36,I6:I36")) Is Nothing Then
Me.Unprotect
On Error Resume Next
'GetMoreSpeed2
For Each rng In Target
If rng = "" Then
rng.Interior.ColorIndex = IIf(rng.Offset(0, -2) = 0, xlNone, 36)
Else
Set rngF = Sheets("Stamm").Range("Namen").Find(rng)
If Not rngF Is Nothing Then
rng.Interior.ColorIndex = IIf(rngF.Interior.ColorIndex <> 55, rngF.Interior.ColorIndex, 36)
rng.Font.Bold = rngF.Font.Bold
rng.Font.Italic = rngF.Font.Italic
End If
Set rngF = Nothing
End If
Next
'GetMoreSpeed2 0
On Error GoTo 0
Me.Protect
End If
End Sub

Kannst du meinen Fehler entdecken?
MfG Dirk N.
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige