Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1156to1160
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

Daten von Quell- in Zieldatei kopieren ohne doppel

Daten von Quell- in Zieldatei kopieren ohne doppel
Quell-
Hallo,
ein freundlicher Mitarbeiter hat mir hier vor einiger Zeit einen Quellcode zur Verfügung gestellt, der folgendes bewirkt:
ich habe mehrere Arbeitsmappen (Quelldateien), die ständig befüllt werden. Die jeweils neuen Daten werden durch markieren und dann klicken auf einen Button in eine andere Arbeitsmappe (Zieldatei), die sich im Hintergrund öffnet und nach dem hineinkopieren wieder schließt, hineinkopiert (angehängt). Die Dateien haben allesamt die gleiche Struktur. Der Quellcode, der auch funktioniert, ist folgender:
Sub myCopy3()
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
mySelection = Selection
ReDim myCounter(1 To UBound(mySelection))
For i = LBound(mySelection()) To UBound(mySelection())
myCounter(i) = mySelection(i, 1)
Next
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()) To UBound(mySelection())
.Cells(lngLastRow + i, 1).Offset(1, 0) = myCounter(i)
Next
End With
objXLWorkbooks(neuWkb).Close savechanges:=True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objXLApp = Nothing
Set objXLWorkbooks = Nothing
End Sub

Jetzt sollen die Quelldateien um eine Funktionalität erweitert werden:
Der Eintrag in Spalte B ist eindeutig 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 in der Spalte B schon eimal vorhanden sind. Sollte dies der Fall sein, dann sollen diese Daten durch die neu einzufügenden ersetzt werden 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.
Mit freundlichen Grüßen
Stefan

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Daten von Quell- in Zieldatei kopieren ohne doppel
21.05.2010 07:14:41
Quell-
Hallo Stefan,
es geht vielleicht auch einfacher. Ich konnte den Code nicht testen.
Option Explicit
Sub myCopy3()
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
' Neu
Dim RaFound As Range
Dim LoZeile As Long
mySelection = Selection
ReDim myCounter(1 To UBound(mySelection))
For i = LBound(mySelection()) To UBound(mySelection())
myCounter(i) = mySelection(i, 1)
Next
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
' Neu
LoZeile = LBound(mySelection())
For i = LBound(mySelection()) To UBound(mySelection())
.Cells(lngLastRow + LoZeile, 1).Offset(1, 0) = myCounter(i)
' vergleich ob der eingefügte Satz schon vorhanden
Set RaFound = .Range("B1:B" & lngLastRow).Find(.Cells(lngLastRow + i, 1), , ,  _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
.Row(lngLastRow + LoZeile + 1).Delete
Else
LoZeile = LoZeile + 1
End If
Next
End With
objXLWorkbooks(neuWkb).Close savechanges:=True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objXLApp = Nothing
Set objXLWorkbooks = Nothing
Set RaFound = Nothing
End Sub


Anzeige
Nachbearbeitung
21.05.2010 11:44:14
Steffen
Hallo Stefan,
das Konstrukt ist von mir.
Der "Alte" Code überträgt nur die Spalte A ,wenn aber Spalte B auf Doppelte geprüft werden soll muss logischer Weise min auch 2 Spalten übertragen werden.
Ich habe mal den Code jetzt so angepasst das der gesammte Ausgewählte Bereich übertragen wird mit der Prämisse aus der Prüfung in Spalte B.
Hoffe Ich hatte dich richtig verstanden..
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

Viele Grüße
Steffen
Anzeige
AW: Nachbearbeitung
21.05.2010 13:52:17
Stefan
Hallo,
Herzlichen Dank für die Hilfe, im Moment ist es so, daß bei der Ausführung der Code an der fett markierten Stelle (Auszug aus dem Gesamtcode), gelb untermalt mit gelbem Pfeil stehen, stehen bleibt (nachdem ich bei der Fehlermeldung auf "Debuggen" geklickt habe).
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
Viele Grüße
Stefan
Anzeige
AW: NachbearbeitungPartII
21.05.2010 21:46:38
Steffen
Hallo Stefan,
kann den Fehler leider nicht nachvollziehen.
Hier noch ein Paar Fragen zur lösung des Problems:
Hast Du den Code komplett in deine Mappe kopiert?
welcher Fehlercode wird angezeigt?
ggf mal Bsp Mappen hochladen.
Viele Grüße
Steffen
AW: NachbearbeitungPartII
22.05.2010 05:46:25
Stefan
Hallo,
vielen Dank für Deine Hilfe. Also 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. Der Code ist komplett in die Arbeitsmappe kopiert. Ich werde aber auch alles nochmal nachprüfen.
Allerdings bin ich ab heute über Pfingsten und die Woche danach bis zum 29.05. im Urlaub. Und bis dahin weiß ich nicht wie die Gelegenheit ist hier reinzuschauen. Es eilt also nicht so. Ich hoffe ich kann mich aber wenn ich wieder zurück bin nochmal in dieser Angelegenheit an dich bzw. das Forum wenden.
Nochmals herzlichen Dank und Frohes Wochenende.
Viele Grüße
Stefan
Anzeige

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige