exel..doppelte einträge verhindern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim z As Integer, i As Integer If Not Intersect(Target, Range("A:A")) Is Nothing Then If Target.Value "" Then i = Range("A65536").End(xlUp).Offset(0 - 1, 0).Row For z = 1 To i Step 1 If Cells(z, 1).Value = Target.Value Then MsgBox ("Wert schon vorhanden") Target.ClearContents End If Next z End If End If geht für die anderen Spalten genauso. Gruß aus Bayern Chaos End Sub

Servus Ernst,
im Moment wird nur geprüft, wo eingegeben wurde.
Hier:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim z As Integer, i As Integer
If Not Intersect(Target, Range("B:B")) Is Nothing Then
If Target.Value  "" Then
i = Range("B65536").End(xlUp).Offset(0 - 1, 0).Row
For z = 1 To i Step 1
If Cells(z, 2).Value  "" Then
If Cells(z, 2).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
End If
End If
If Cells(z, 3).Value  "" Then
If Cells(z, 3).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
End If
End If
If Cells(z, 9).Value  "" Then
If Cells(z, 9).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
End If
End If
If Cells(z, 10).Value  "" Then
If Cells(z, 10).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
End If
End If
If Cells(z, 16).Value  "" Then
If Cells(z, 16).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
End If
End If
If Cells(z, 17).Value  "" Then
If Cells(z, 17).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
End If
End If
Next z
End If
End If
End Sub

wird in allen Spalten geprüft, die du angegeben hast, wenn irgendwas in den Zellen drin steht, aber nur bis zu der Zeile, wo du in Spalte B bereits Werte stehen hattest.
Dieses Makro gilt aber momentan nur für Eingaben in Spalte B, für die anderen Spalten musst du den Kopf in If Intersect(Target, Range("gewünschte Spalte:gewünschteSpalte") abbändern und das komplette Makro unten anhängen.
Also so:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim z As Integer, i As Integer
If Not Intersect(Target, Range("B:B")) Is Nothing Then
If Target.Value  "" Then
i = Range("B65536").End(xlUp).Offset(0 - 1, 0).Row
For z = 1 To i Step 1
If Cells(z, 2).Value  "" Then
If Cells(z, 2).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 3).Value  "" Then
If Cells(z, 3).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 9).Value  "" Then
If Cells(z, 9).Value = Target.Value Then
MsgBox ("Wert in Spalte B schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 10).Value  "" Then
If Cells(z, 10).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 16).Value  "" Then
If Cells(z, 16).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 17).Value  "" Then
If Cells(z, 17).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
Next z
End If
End If
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Value  "" Then
i = Range("C65536").End(xlUp).Offset(0 - 1, 0).Row
For z = 1 To i Step 1
If Cells(z, 2).Value  "" Then
If Cells(z, 2).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 3).Value  "" Then
If Cells(z, 3).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 9).Value  "" Then
If Cells(z, 9).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 10).Value  "" Then
If Cells(z, 10).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 16).Value  "" Then
If Cells(z, 16).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
If Cells(z, 17).Value  "" Then
If Cells(z, 17).Value = Target.Value Then
MsgBox ("Wert schon vorhanden")
Target.Select
Exit Sub
End If
End If
Next z
End If
End If
End Sub

das ist jetzt für Eingabe in B und C mit Überprüfung aller von dir genannten Spalten B = 2, C=3;I = 9, J=10, P = 16 und Q = 17
Gruß
Chaos

Private Sub Worksheet_Change(ByVal Target As Range) Dim aSpalten If Target.Count > 1 Or _ Target.Value = "" Then Exit Sub aSpalten = Array(" ", "A", "B", "C", "D", "E", "F", "G", "H", _ "I", "J", "K", "L", "M", "N", "O", "P", "Q") If Target.Column = 2 Or Target.Column = 3 Or Target.Column = 9 Or _ Target.Column = 10 Or Target.Column = 17 Then If Application.WorksheetFunction.CountIf(Columns(Target.Column), _ Target.Value) > 1 Then MsgBox "die Eingabe """ & Target.Value & """ gibt es" & Chr(10) & _ "in der Spalte """ & aSpalten(Target.Column) & """ bereits.", _ 48, " Hinweis für " & Application.UserName Target.Value = "" Cells(Target.Row, Target.Column).Select End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim aSpalten If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub aSpalten = Array(" ", "A", "B", "C", "D", "E", "F", "G", "H", _ "I", "J", "K", "L", "M", "N", "O", "P", "Q") If Target.Column = 2 Or Target.Column = 3 Or _ Target.Column = 9 Or Target.Column = 10 Or _ Target.Column = 16 Or Target.Column = 17 Then If Application.WorksheetFunction.CountIf(Columns(Target.Column), _ Target.Value) > 1 Then MsgBox "die Eingabe """ & Target.Value & """ gibt es" & Chr(10) & _ "in der Spalte """ & aSpalten(Target.Column) & """ bereits.", _ 48, " Hinweis für " & Application.UserName Target.Value = "" Cells(Target.Row, Target.Column).Select End If End If End Sub

Hallo Ernst,
dann versuch es so:

'
'   Wenn eine Eingabe in Spalte B, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte C, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte I, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte J, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte P, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte Q, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte V, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'   Wenn eine Eingabe in Spalte W, dann keine doppelten in Spalte(n) B,C,I,J,P,Q,V,W
'
'   Das wär's was ich konkret brauchen würde. Nach jeder Eingabe sollten folgende
'   Spalten (B, C, I, J, P, Q, V, W) auf doppelte Einträge überprüft werden...
'
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSpalte   As Variant  ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex    As Integer  ' Index für den Spalten-Array
   If Target.Count > 1 Then Exit Sub   ' mehr als eine Zelle markiert ?
   If Target.Value = "" Then Exit Sub  ' ist die Zelle gefüllt ?
'
'                  B  C  I   J   P   Q   V   W
   iSpalte = Array(2, 3, 9, 10, 16, 17, 22, 23) ' die Spalten-Nummern als Array
   If Target.Column = 2 Or Target.Column = 3 Or _
      Target.Column = 9 Or Target.Column = 10 Or _
      Target.Column = 16 Or Target.Column = 17 Or _
      Target.Column = 22 Or Target.Column = 23 Then  ' eine gültige Eingabe-Spalte ?
      For iIndex = 0 To UBound(iSpalte)          ' alle Spalten abarbeiten/vergleichen
         If Target.Column = iSpalte(iIndex) Then ' ist es die Eingabespalte ?
            If Application.WorksheetFunction.CountIf(Columns(Target.Column), _
               Target.Value) > 1 Then  ' zählen in der Eingabespalte
               If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
                  "in der Spalte """ & Chr(Asc("@") + Target.Column) & """ bereits." _
                  & Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
                  vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
                  Exit Sub
                Else
                  Target.Value = ""                       ' die Eingabe löschen
                  Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
                  Exit For
               End If
            End If
         Else                                    ' es ist NICHT die Eingabspalte !
            If Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
               Target.Value) > 0 Then  ' zählen in den NICHT Eingabespalten
               If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
                  "in der Spalte """ & Chr(Asc("@") + Target.Column) & """ bereits." _
                  & Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
                  vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
                  Exit Sub
                Else
                  Target.Value = ""                       ' die Eingabe löschen
                  Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
                  Exit For
               End If
            End If
         End If
      Next iIndex
   End If
End Sub

Gruß aus Hamburg, Peter

Beliebteste Forumthreads (12 Monate)

exel..doppelte einträge verhindern

29 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread