Daten von Quell- in Zieldatei kopieren ohne doppel
Quell-
mein Name ist Stefan, ich habe am 2010-05-20 20:13:15 einen Beitrag unter dem gleichen Betreff geschrieben (Archiv-IDX 1158172) und habe von Steffen freundlicherweise eine Antwort bekommen, in der er mich gebeten hat gegebenenfalls Mappen hochzuladen. Ich möchte dies nun tun und zwei beispiele hochladen.
https://www.herber.de/bbs/user/69802.xlsx
https://www.herber.de/bbs/user/69803.xlsx
Noch einmal kurz das Problem:
ich habe mehrere Arbeitsmappen (Quelldateien, z. Bsp. GSZ_Preisfindung.xls), die ständig befüllt werden. Die jeweils neuen Daten sollen durch markieren und dann klicken auf einen Button in eine andere Arbeitsmappe (Zieldatei, GSZ_2010.xls), die sich im Hintergrund öffnet und nach dem hineinkopieren wieder schließt, hineinkopiert (angehängt) werden. Die Dateien haben allesamt die gleiche Struktur. Die schon vorhandenen Zeilen in den Queldateien können sich durch nachträgliche Einträge verändern mit Ausnahme von Spalte B. Der Eintrag in Spalte B ist eine eindeutige Kennnummer und darf nicht doppelt vorkommen. Es soll also zu der bisherigen Funktionalität noch überprüft werden, ob die vom Anwender markierten und zu kopierenden Daten schon eimal mit der gleichen Kennnummer in Spalte B vorhanden sind. Sollte dies der Fall sein, dann sollen diese Daten durch die neu einzufügenden, sozusagen aktuellen, ersetzt und andernfalls wie gehabt angehängt werden. Ich hoffe ich habe mich deutlich ausgedrückt. Ist dies möglich? Hintergrund ist, schon vorhandene Datensätze können sich in den Quelldateien jederzeit verändern, außer eben in Spalte B. Diese Veränderungen sollen immer auf dem neuesten Stand sein ohne , daß in Spalte B doppelte einträge vorkommen.
Der Mitarbeiter Steffen hat mir dankbarerweise folgenden Code geschrieben:
Sub myCopy4()
Dim objXLApp As Excel.Application
Dim objXLABC As Excel.Workbook
Dim objXLWorkbooks As Excel.Workbooks
Dim neuWkb
Dim lngLastRow As Long
Dim mySelection()
Dim myCounter()
Dim i As Long
Dim x As Long
Dim n As Long
Dim mysearch
Dim mySearchRow As Long
mySelection = Selection
ReDim myCounter(1 To UBound(mySelection, 1), 1 To UBound(mySelection, 2))
For i = LBound(mySelection, 1) To UBound(mySelection, 1)
For x = LBound(mySelection, 2) To UBound(mySelection, 2)
myCounter(i, x) = mySelection(i, x)
Next x
Next i
Set objXLApp = New Excel.Application
Set objXLWorkbooks = objXLApp.Workbooks
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set objXLABC = objXLWorkbooks.Open("C:\Stefan\Mappe2.xls")
neuWkb = objXLABC.Name
With objXLWorkbooks(neuWkb).Sheets(1)
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LBound(mySelection, 1) To UBound(mySelection, 1)
For x = LBound(mySelection, 2) To UBound(mySelection, 2)
Set mysearch = .Range("B1:B" & lngLastRow).Find(myCounter(i, 2), lookat:=xlWhole)
If Not mysearch Is Nothing Then
mySearchRow = mysearch.Row
.Cells(mySearchRow, x) = myCounter(i, x)
Else
n = .Cells(.Rows.Count, x).End(xlUp).Row
.Cells(n + 1, x) = myCounter(i, x)
End If
Next x
Next i
End With
objXLWorkbooks(neuWkb).Close savechanges:=True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objXLApp = Nothing
Set objXLWorkbooks = Nothing
End Sub
Leider funktioniert er bei mir noch nicht. Die Reaktion des Programms ist folgende: Es erscheint nur die Sanduhr, die ja anzeigt, daß der Rechner tätig ist, das dauert so lange bis ich mit ESCAPE unterbreche. Dann erscheint ein Fenster mit 3 Auswahlmöglichkeiten, unter anderem der Möglichkeit "Debuggen". Wenn ich darauf klicke erscheint ein gelber Pfeil und die oben markierte Textstelle wird gelb unterlegt (mySearchRow = mySearch.Row).
Ich hoffe ich habe mich verständlich ausgedrückt. Kann mir jemand damit helfen?
Mit freundlichen Grüßen
Stefan