Keine doppelte einfügen

Hallo,
ich habe eine Excel-Datei, die die Funktion db_fill enthält. Diese Funktion übergibt die Zeilen aus der Excel-Datei in eine andere Excel-Datei.
Das funktioniert derzeit nur bedingt. In der neuen Datei soll die nächste freie Zeile am Ende gesucht werden und dann sollen die Datensätze eingefügt werden. Den Dateinamen der Quell-Excel-Datei speichere ich auch in einer Spalte ab. Damit keine doppelten entstehen sollte vorher noch geprüft werden, ob der Quell-Excel-Dateiname schon in der Spalte existiert, dann soll nichts eingefügt werden. Nur wenn es keine großen Umstände macht, soll noch geschaut werden, ob die FirmaNr schon existiert und dann sollen nur die Datensätze eingefügt werden, deren FirmaNr in der Ziel-Datei nicht existieren.
Für konkrete Codeverbesserungen bin ich sehr dankbar!!!


Sub db_fill()
Application.ScreenUpdating = False
Dim i As Long
Dim x As Integer
Dim WbA As Workbook
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim dateiname As String
Dim letzteZeile As Long
Dim a
Set WbA = Workbooks("crm_db.xls")      'Zieldatei
Set Ws1 = ThisWorkbook.Worksheets(1)   'Quelldatei
Set Ws2 = WbA.Worksheets("Data")       'Ziel
Dim j As Long
dateiname = Ws1.Parent.Name
letzteZeile = Ws2.UsedRange.Rows.Count
j = 1
x = 1
Ws2.Rows("1:1").Font.Bold = True
Ws2.Cells(x, 1) = "FB"
Ws2.Cells(x, 2) = "FirmaNr"
Ws2.Cells(x, 3) = "Erstelldatum"
Ws2.Cells(x, 4) = "Anrede1"
Ws2.Cells(x, 5) = "Titel1"
Ws2.Cells(x, 6) = "Vorname1"
Ws2.Cells(x, 7) = "Name1"
Ws2.Cells(x, 8) = "Anrede2"
Ws2.Cells(x, 9) = "Titel2"
Ws2.Cells(x, 10) = "Vorname2"
Ws2.Cells(x, 11) = "Name2"
Ws2.Cells(x, 12) = "Strasse"
Ws2.Cells(x, 13) = "Land"
Ws2.Cells(x, 14) = "PLZ"
Ws2.Cells(x, 15) = "Ort"
Ws2.Cells(x, 16) = "Stadtteil"
Ws2.Cells(x, 17) = "Tel"
Ws2.Cells(x, 18) = "Bemerkung1"
Ws2.Cells(x, 19) = "Fax"
Ws2.Cells(x, 20) = "Mobil"
Ws2.Cells(x, 21) = "Bemerkung2"
Ws2.Cells(x, 22) = "Mail"
Ws2.Cells(x, 23) = "Bemerkung3"
Ws2.Cells(x, 24) = "Interessentenart"
Ws2.Cells(x, 25) = "FBinfo"
Ws2.Cells(x, 26) = "Aktion"
Ws2.Cells(x, 27) = "Kontaktaufnahme"
Ws2.Cells(x, 28) = "Firmenklasse"
Ws2.Cells(x, 29) = "Infopaket"
Ws2.Cells(x, 30) = "Dateiname"
Ws2.Cells(x, 31) = "Einfügedatum"
Ws2.Cells(x, 32) = "geändert am"
Ws2.Cells(x, 33) = "Klassifikation"
Ws2.Cells(x, 34) = "BemerkungFB"
Ws2.Cells(x, 35) = "Wiedervorlage"
For i = 2 To Ws1.UsedRange.Rows.Count
With Ws2
Set a = .Range(.Cells(1, 1), .Cells(letzteZeile, 1)).Find(Ws1.Cells(i, 1))
If a Is Nothing Then
.Cells(letzteZeile + j, 1).Value = Ws1.Cells(i, 1).Value
.Cells(letzteZeile + j, 2).Value = Ws1.Cells(i, 2).Value
.Cells(letzteZeile + j, 3).Value = Ws1.Cells(i, 3).Value
.Cells(letzteZeile + j, 4).Value = Ws1.Cells(i, 4).Value
.Cells(letzteZeile + j, 5).Value = Ws1.Cells(i, 5).Value
.Cells(letzteZeile + j, 6).Value = Ws1.Cells(i, 6).Value
.Cells(letzteZeile + j, 7).Value = Ws1.Cells(i, 7).Value
.Cells(letzteZeile + j, 8).Value = Ws1.Cells(i, 8).Value
.Cells(letzteZeile + j, 9).Value = Ws1.Cells(i, 9).Value
.Cells(letzteZeile + j, 10).Value = Ws1.Cells(i, 10).Value
.Cells(letzteZeile + j, 11).Value = Ws1.Cells(i, 11).Value
.Cells(letzteZeile + j, 12).Value = Ws1.Cells(i, 12).Value
.Cells(letzteZeile + j, 13).Value = Ws1.Cells(i, 13).Value
.Cells(letzteZeile + j, 14).Value = Ws1.Cells(i, 14).Value
.Cells(letzteZeile + j, 15).Value = Ws1.Cells(i, 15).Value
.Cells(letzteZeile + j, 16).Value = Ws1.Cells(i, 16).Value
.Cells(letzteZeile + j, 17).Value = Ws1.Cells(i, 17).Value
.Cells(letzteZeile + j, 18).Value = Ws1.Cells(i, 18).Value
.Cells(letzteZeile + j, 19).Value = Ws1.Cells(i, 19).Value
.Cells(letzteZeile + j, 20).Value = Ws1.Cells(i, 20).Value
.Cells(letzteZeile + j, 21).Value = Ws1.Cells(i, 21).Value
.Cells(letzteZeile + j, 22).Value = Ws1.Cells(i, 22).Value
.Cells(letzteZeile + j, 23).Value = Ws1.Cells(i, 23).Value
.Cells(letzteZeile + j, 24).Value = Ws1.Cells(i, 24).Value
.Cells(letzteZeile + j, 25).Value = Ws1.Cells(i, 25).Value
.Cells(letzteZeile + j, 26).Value = Ws1.Cells(i, 26).Value
.Cells(letzteZeile + j, 27).Value = Ws1.Cells(i, 27).Value
.Cells(letzteZeile + j, 28).Value = Ws1.Cells(i, 28).Value
.Cells(letzteZeile + j, 29).Value = Ws1.Cells(i, 29).Value
.Cells(letzteZeile + j, 30).Value = dateiname
.Cells(letzteZeile + j, 31).Value = Now
j = j + 1
End If
End With
Next i
Ws2.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Sub db_fill() Application.ScreenUpdating = False Dim i As Long Dim WbA As Workbook Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim letzteZeile As Long Dim a Set WbA = Workbooks("crm_db.xls") 'Zieldatei Set Ws1 = ThisWorkbook.Worksheets(1) 'Quelldatei Set Ws2 = WbA.Worksheets("Data") 'Ziel letzteZeile = Ws2.Range("A65536").End(xlUp).Row If letzteZeile = 1 And Ws2.Range("A1") = "" Then Ws2.Rows("1:1").Font.Bold = True kopf = "FB FirmaNr Erstelldatum Anrede1 Titel1 Vorname1 Name1 Anrede2 Titel2 Vorname2" kopf = kopf & " Name2 Strasse Land PLZ Ort Stadtteil Tel Bemerkung1 Fax Mobil Bemerkung2" kopf = kopf & " Mail Bemerkung3 Interessentenart FBinfo Aktion Kontaktaufnahme Firmenklasse" kopf = kopf & " Infopaket Dateiname Einfügedatum geändert am Klassifikation BemerkungFB Wiedervorlage" Ws2.Range("A1:AI1") = Split(kopf) End If With Ws2 Set a = .Range("AD2:AD" & letzteZeile).Find(ThisWorkbook.Name, LookIn:=xlValues) If Not a Is Nothing Then Exit Sub For i = 2 To Ws1.Range("A65536").End(xlUp).Row Set a = .Range("B2:B" & letzteZeile).Find(Ws1.Cells(i, 2)) 'nach FirmaNr suchen If a Is Nothing Then Ws1.Range("A" & i & ":AI" & i).Copy Destination:=.Range("A" & letzteZeile + 1) letzteZeile = letzteZeile + 1 End If Next i .Columns.AutoFit End With Set WbA = Nothing Set Ws1 = Nothing Set Ws2 = Nothing Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread