Clever-Excel-Forum

Clever-Excel-Forum > Office-Anwendungen > Excel > Excel VBA keine doppelten werte bis auf eine Zahl!
Normale Version: Excel VBA keine doppelten werte bis auf eine Zahl!
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.

Pascala

27.07.2020, 06:56
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

27.07.2020, 09:54
Hallo,

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

Gruß Uwe

Pascala

27.07.2020, 09:59
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

28.09.2020, 13:53
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

28.09.2020, 14:47
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

29.09.2020, 11:42
Vielen vielen Dank Uwe!

Klappt Super.
Clever-Excel-Forum > Office-Anwendungen > Excel > Excel VBA keine doppelten werte bis auf eine Zahl!