Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1800to1804
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
Inhaltsverzeichnis

VBA Datenerfassung ohne Duplikate

VBA Datenerfassung ohne Duplikate
26.12.2020 16:07:30
Marko
Hallo,
ich brauche einen Code, der die Erfassung von Duplikaten verhindert.
Eingabe in „Tabelle3“
- Zelle C5 = Kundennummer
- Zelle C11 = Produktname
Erfassung in „Tabelle4“ (ab Zeile 2, in Zeile 1 stehen die Überschriften)
- Spalte A = Kundennummer
- Spalte B = Produktname
Wenn für den Kunden ein Produkt bereits erfasst worden und der Tabelle4 bereits vorhanden ist, soll sich eine MsgBox öffnen mit Ja/Nein Abfrage:
- „Datensatz ist bereits vorhanden“ – wollen sie diesen überschreiben?
- Wenn Ja, dann soll der vorhandene Datensatz überschrieben werden.
- Wenn Nein, dann soll nichts gesehen.
Die Übertragung von Tabelle3 in die Tabelle4 erfolgt mit folgenden Code:
Private Sub CommandButton1_Click()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim raBereich As Range
With Worksheets("Tabelle3")
Set raBereich = Union(.Range("C5"), .Range("C11"), .Range("C19"))
raBereich.Copy
With Worksheets("Tabelle4")
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row, 1) _
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Application.CutCopyMode = False
End With
Range("C5").ClearContents
Range("C11").ClearContents
Range("C19").ClearContents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Wie kann diese Aufgabe gelöst werden? Leider reichen meine VBA Kenntnisse hierfür nicht aus. Vielen Dank für Eure Hilfe.

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Datenerfassung ohne Duplikate
26.12.2020 22:29:02
fcs
Hallo Marko,
so sollte es funktionieren.
LG
Franz
Private Sub CommandButton1_Click()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim raBereich As Range
Dim KndProd As Variant
Dim WerteTab4 As Variant
Dim Zeile As Long, zeiTab As Long
With Worksheets("Tabelle3")
Set raBereich = Union(.Range("C5"), .Range("C11"), .Range("C19"))
KndProd = .Range("C5").Text & " | " & .Range("C11")
With Worksheets("Tabelle4")
zeiTab = .Cells(.Rows.Count, 1).End(xlUp).Row
WerteTab4 = .Range(.Cells(2, 1), .Cells(zeiTab, 2))
zeiTab = 1
For Zeile = LBound(WerteTab4) To UBound(WerteTab4)
zeiTab = zeiTab + 1
If KndProd = WerteTab4(Zeile, 1) & " | " & WerteTab4(Zeile, 2) Then
If MsgBox("Produkt ist für Kunde schon vorhanden" & vbLf _
& KndProd & vbLf _
& "Daten überschreiben?", vbQuestion + vbYesNo, "Daten übertragen") = vbYes  _
Then
raBereich.Copy
.Cells(zeiTab, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
GoTo weiter
End If
Next
raBereich.Copy
.Cells(zeiTab + 1, 1) _
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
weiter:
Application.CutCopyMode = False
.Range("C5").ClearContents
.Range("C11").ClearContents
.Range("C19").ClearContents
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Anzeige
VBA Email mit Anhang als PDF
27.12.2020 01:05:44
Marko
Hallo Franz,
PERFEKT !!! Das Makro funktioniert. Vielen, vielen Dank.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige