Excel VBA keine doppelten werte bis auf eine Zahl!

[Pascala]

Guten Morgen zusammen,

ich habe ein kleines Problem.
Ich möchte in einer spalte keine doppelten Werte bis auf eine bestimmte zahl z.b.: 200100 darf doppelt oder auch öfter vorkommen.
Ich habe zur Ermittlung von doppelten werten folgenden Code.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("A5:A3005")
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Bereich, Target) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Bereich, Target.Value) > 1 Then
    Beep
    UserForm1.Show
    Application.EnableEvents = False
    Target.Value = ""
    Application.EnableEvents = True
    Target.Select
End If
    Dim objRange As Range, objCell As Range
    Set objRange = Intersect(Target, Range("A5:A3005"))
    If Not objRange Is Nothing Then
        Application.EnableEvents = False
        For Each objCell In objRange
            If Not IsEmpty(objCell.Value) Then
                objCell.Offset(0, 1).Value = Now
            Else
                objCell.Offset(0, 1).Value = Empty
            End If
        Next
        Application.EnableEvents = True
    End If
End Sub

Nun wollte ich fragen wie ich diesen Code ändern soll damit er z.b. den Wert 200100 nicht berücksichtigt.

Danke & viele Grüße.

[Kuwer]

Hallo,

Code:

If WorksheetFunction.CountIf(Bereich, Target.Value) > 1 And Target.Value <> 200100 Then

Gruß Uwe

[Pascala]

Falls dies nicht umsetzbar ist würde mir eine Änderung des Codes auf nur Numerische Kontrolle der doppelten werte weiterhelfen.

Danke & viele Grüße.

EDIT:

Entschuldigung hab erst jetzt gesehen das du auf mein Problem geantwortet hast.

Danke dir für deine Antwort!

Mein Problem ist nun damit gelöst. :)

[Pascala]

Hallo zusammen,

der Code oben lässt keine Doppelten Werte zu bis auf die 200000.
Wie müsste ich den Code verändern wenn ich auch alle Zahlen die mit *999 enden erlauben möchte?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("A5:A3005")
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Bereich, Target) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Bereich, Target.Value) > 1 And Target.Value <> 200100 Then 'Auswahl der Zahl die doppelt gescannt werden darf. Unbekannt Aktuell "200000"
    Beep
    UserForm1.Show
    Application.EnableEvents = False
    Target.Value = ""
    Application.EnableEvents = True
    Target.Select
End If
    Dim objRange As Range, objCell As Range
    Set objRange = Intersect(Target, Range("A5:A3005"))
    If Not objRange Is Nothing Then
        Application.EnableEvents = False
        For Each objCell In objRange
            If Not IsEmpty(objCell.Value) Then
   objCell.Offset(0, 1).Value = Now
            Else
                objCell.Offset(0, 1).Value = Empty
            End If
        Next
        Application.EnableEvents = True
    End If

Danke & viele Grüße.

[Kuwer]

Hallo,

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Bereich As Range
  Dim objRange As Range, objCell As Range
  
  Set Bereich = Range("A5:A3005")
  If Target.Cells.Count > 1 Then Exit Sub
  If Target.Value = "" Then Exit Sub
  If Intersect(Bereich, Target) Is Nothing Then Exit Sub
  If WorksheetFunction.CountIf(Bereich, Target.Value) > 1 Then
    If Target.Value <> 200100 And Right(Target.Value, 3) <> "999" Then 'Auswahl der Zahl die doppelt gescannt werden darf. Unbekannt Aktuell "200000"
        Beep
        UserForm1.Show
        Application.EnableEvents = False
        Target.Value = ""
        Application.EnableEvents = True
        Target.Select
    End If
    Set objRange = Intersect(Target, Bereich)
    If Not objRange Is Nothing Then
        Application.EnableEvents = False
        For Each objCell In objRange
            If Not IsEmpty(objCell.Value) Then
                objCell.Offset(0, 1).Value = Now
            Else
                objCell.Offset(0, 1).Value = Empty
            End If
        Next
        Application.EnableEvents = True
    End If
    End If
  End If
End Sub

Gruß Uwe

[Pascala]

Vielen vielen Dank Uwe!

Klappt Super.