Opgelost Aanpassing

[Mark_68]

Ik heb onderstaande code voor het controleren van dubbele waardes, alleen werkt deze alleen als je de gegevens invoert in deze kolom. Nu worden bij mij de waardes in deze kolom gekopieerd vanaf een ander tabblad en werkt deze code niet. Nu is mijn vraag hoe kan ik deze code aanpassen zodat deze wel werkt.

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Column > 2 Or .Cells.Count > 1 Then Exit Sub
If WorksheetFunction.CountIf(Columns(.Column), .Value) > 1 Then
Application.DisplayAlerts = False
.ClearContents
Application.DisplayAlerts = True
MsgBox "Bestaat reeds!"
End If
End With
End Sub

 

[Warme bakkertje]

Ik veronderstel dat je dus telkens nieuwe waarden plakt onderaan de bestaande waarden.
En dat je kolomkoppen hebt en de data in rij 2 start.
Probeer eens met deze.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 Then Exit Sub
    Data = ActiveSheet.UsedRange.Columns(Target.Column).Value
    Set dic = CreateObject("scripting.dictionary")
    With dic
        For r = 1 To UBound(Data)
            x0 = dic.Item(Data(r, 1))
        Next
        Application.EnableEvents = False
        With Cells(2, Target.Column)
            .Resize(UBound(Data)).ClearContents
            .Resize(dic.Count) = Application.Transpose(dic.keys())
        End With
        Application.EnableEvents = True
    End With
End Sub

 

[Warme bakkertje]

Als je beschikt over Excel2021 of O365 dan kan het nog iets simpeler.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim unique As Variant
    With ActiveSheet
        unique = Application.unique(.UsedRange.Columns(Target.Column))
        Application.EnableEvents = False
        With .Cells(2, Target.Column)
            .Resize(Rows.Count - 1).ClearContents
            .Resize(UBound(unique)) = Application.Index(unique, 0, 1)
        End With
        Application.EnableEvents = True
    End With
End Sub

 

[Warme bakkertje]

In je antwoord schrijf je dat de code enkel een waarschuwing moet geven. Wat doet dit dan in je code?

.ClearContents

Ook schrijf je dat je hele formulier bijna wordt leeggegooid. Als je de gekopieerde waardes onderaan 1 v/d kolommen plakt wordt de voorgaande volgorde gerespecteerd en worden enkel de niet dubbele waarden toegevoegd.
Misschien moet je je werkwijze ook maar eens verduidelijken.

 

[Mark_68]

Ik wil jullie bedanken voor het reageren, maar heb de oplossing reeds zelf gevonden

 

[OctaFish]

Waarom meld je dat dan niet? Nu zit warme bakker zit de peentjes te zweten op allerlei mooie oplossingen voor je. Dus: a) melden, en b) vermelden hoe je het hebt opgelost. Zo doe je dat in een forum .

 

[Mark_68]

Volgens mij heb ik het gemeld met het bericht #5
Mijn excuses voor het niet vermelden van hoe ik het gedaan heb, maar zie onderstaande oplossing

Private Sub txtBatchnummer_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If cmbMateriaal = "Aluminium" And txtBatchnummer.Text <> "" Then
Set c = Sheets("Aluminium").Range("B:B").Find(txtBatchnummer.Text, , , xlWhole)
If Not c Is Nothing Then
If MsgBox("Dit batchnummer bestaat al, wilt u het opnieuw invoeren?", vbQuestion + vbYesNo, "Confirmation") = vbYes Then
txtBatchnummer.Cut
Me.txtBatchnummer.Value = ""
Cancel = True
End If
End If
End If