Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1172to1176
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
Dateien von Quell- in Zieldatei kopieren
Quell-
Hallo,
ich beziehe mich auf einen früheren Beitrag von mir: Archiv-IDX 1159429 2010-05-30 12:36:39
mit dem Thema Daten von Quell- in Zieldatei kopieren ohne doppel. Folgender Quellcode wurde
mir von Franz zur Verfügung gestellt (ich hatte unter dieser Archiv-IDX auch Beispieldateien hochgeladen):
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

Das Programm leistet folgendes: Es kopiert aus verschiedenen dynamisch gepflegten Quelldateien mit gleicher Struktur die markierten Datensätze in eine Zieldatei (sozusagen die Gesamtdatei - auch die gleiche Struktur) und überschreibt in der Zieltabelle Datensätze, falls in Spalte B gleiche Daten stehen. D.h. es gibt keine doppelten Daten in Spalte B. Dabei wird die Zieldatei im Hintergrund automatisch geöffnet und wieder geschlossen.
Mein Problem: Ich möchte in die Zieltabelle eine Spalte einfügen in deren Zellen der Name der jeweiligen Quelldatei, aus der heraus die Zieldatei gerade befüllt wird, eingefügt wird. Aber nur der Name und nicht der ganze Pfad.
Kann mir hiermit jemand weiterhelfen?
Liebe Grüße
Stefan
AW: Dateien von Quell- in Zieldatei kopieren
13.08.2010 20:15:18
Quell-
Hallo Stefan,
mit folgenden Anpassungen sollte es funktionieren. Ich hab die Suche in Spalte B nach der Zeile mit dem Wert umgestellt. Einmal pro Durchlauf suchen reicht. ;-)
Gruß
Franz
Sub myCopy4()
Dim objXLApp As Excel.Application
Dim objXLABC As Excel.Workbook
Dim objXLWorkbooks As Excel.Workbooks
Dim neuWkb, sQuellName$
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
sQuellName = ActiveWorkbook.Name ' Name der Quelldatei merken
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)
Set mysearch = .Range("B1:B" & lngLastRow).Find(myCounter(i, 2), lookat:=xlWhole)
If Not mysearch Is Nothing Then
mySearchRow = mysearch.Row
Else
mySearchRow = .Cells(.Rows.Count, x).End(xlUp).Row + 1
End If
For x = LBound(mySelection, 2) To UBound(mySelection, 2)
.Cells(mySearchRow, x) = myCounter(i, x)
Next x
.Cells(mySearchRow, 10) = sQuellName 'Name der Quelldatei einfügen Spalte 10 ggf.  _
anpassen!
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

Anzeige
AW: Dateien von Quell- in Zieldatei kopieren
16.08.2010 14:25:06
Quell-
Hallo Franz,
erst mal herzlichen Dank für deine Hilfe. Ich konnte den Code erst heute testen. Dabei bekam eine Fehlermeldung an der fett markierten Stelle und zwar "Laufzeitfehler 1004 Anwendungs- oder Objektdefinierter Fehler"
Sub CommandButton1_Click()
Dim objXLApp As Excel.Application
Dim objXLABC As Excel.Workbook
Dim objXLWorkbooks As Excel.Workbooks
Dim neuWkb, sQuellName$
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
sQuellName = ActiveWorkbook.Name ' Name der Quelldatei merken
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:\Dokumente und Einstellungen\ex_wagner\ _
K120_GSZ_Themen_Workflow\Workflow_GSZ_2010.xlsm")
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)
Set mysearch = .Range("B1:B" & lngLastRow).Find(myCounter(i, 2), lookat:=xlWhole)
If Not mysearch Is Nothing Then
mySearchRow = mysearch.Row
Else
 mySearchRow = .Cells(.Rows.Count, x).End(xlUp).Row + 1        End If
For x = LBound(mySelection, 2) To UBound(mySelection, 2)
.Cells(mySearchRow, x) = myCounter(i, x)
Next x
.Cells(mySearchRow, 49) = sQuellName 'Name der Quelldatei einfügen Spalte 10 ggf. _
anpassen!
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

Vielleicht noch mal kurz zur Erklärung: In der Zieltabelle soll in der ersten freien Spalte der Name der Quelldatei automatisch eingetragen werden (ohne Endung .xls), das wäre im Moment die Spalte AW - das kann sich aber ändern, da unter Umständen noch Spalten vorher eingefügt werden. Ich habe nochmal 2 Beispieldateien geladen. Ich hoffe das hilft.
https://www.herber.de/bbs/user/71087.xlsx (Zieldatei)
https://www.herber.de/bbs/user/71088.xlsm (Quelldatei)
Dabei soll beim kopieren von der Ziel- in die Quelldatei in dieser automatisch in der Spalte AW (momentan) mit der Überschrift "thematische Workflow" der Name der Quelldatei übernommen werden.
Vielen Dank nochmal für deine Hilfe. Du hast mir schon sehr geholfen.
Liebe Grüße
Stefan
Anzeige
AW: Dateien von Quell- in Zieldatei kopieren
16.08.2010 18:06:04
Quell-
Hallo Stefan,
den folgenden Abschnitt muss du in dem geposteten Code anpassen.
Ich versteh aber nicht, warum du hier unbedingt mit einem neuen Excel-Application-Objekt arbeiten willst. Läuft bei mir mit Netzwerk-Betrieb extrem schlecht/langsam.
With objXLABC.Sheets(1)
For i = LBound(mySelection, 1) To UBound(mySelection, 1)
lngLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set mysearch = .Range("B1:B" & lngLastRow).Find(myCounter(i, 2), lookat:=xlWhole)
If Not mysearch Is Nothing Then
mySearchRow = mysearch.Row
Else
mySearchRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
End If
For x = LBound(mySelection, 2) To UBound(mySelection, 2)
.Cells(mySearchRow, x) = myCounter(i, x)
Next x
'Dateiname der Quelle in letzte Spalte eintragen (ohne Dateierweiterung)
.Cells(mySearchRow, .Cells(1, .Columns.Count).End(xlToLeft).Column) = _
Mid(sQuellName, 1, InStrRev(sQuellName, ".") - 1)
Next i
End With

In der Prozedur des Buttons in der hochgeladenen Datei ist der folgende Abschnitt anzupassen, um den Dateinamen der Quelle einzufügen.
        'vorhandener Schlüssel
lZeile = rngZelle.Row
End If
'Zeile aus Quelle kopieren
wksQuelle.Rows(rngRow.Row).Copy Destination:=wksSammler.Rows(lZeile)
'in letzter Spalte den Dateinamen der Quelle eingetragen
lSpalteQuelldatei = .Cells(1, .Columns.Count).End(xlToLeft).Column 'z.Zt. Spalte AW
.Cells(lZeile, .Cells(1, .Columns.Count).End(xlToLeft).Column) = _
Mid(wksQuelle.Parent.Name, 1, InStrRev(wksQuelle.Parent.Name, ".") - 1)
End With
Next

Gruß
Franz
Anzeige
AW: Dateien von Quell- in Zieldatei kopieren
17.08.2010 07:12:31
Quell-
Hallo Franz,
sorry, wenn ich etwas begriffsstutzig bin, meine VBA Kentnisse sind nicht so ausgeprägt und ich möchte dir auch nicht aufn die Nerven gehen, aber welches ist denn die Prozedur des Buttons?
Liebe Grüße
Stefan
AW: Dateien von Quell- in Zieldatei kopieren
17.08.2010 13:02:33
Quell-
Hallo Stefan,
mit Prozedur des Buttons meine ich das Makro (Prozedur, Code), das per Klick auf die Schaltfläche gestartet wird.
Gruß
Franz
AW: Dateien von Quell- in Zieldatei kopieren
17.08.2010 14:51:31
Quell-
Hallo Franz,
:-), das ist schon okay, aber wo finde ich diesen Teil des Codes im gesamtcode?
Grüße
Stefan
AW: Dateien von Quell- in Zieldatei kopieren
17.08.2010 18:40:25
Quell-
Hallo Stefan,
einmal erstzt du diesen Teil:
   With objXLWorkbooks(neuWkb).Sheets(1)
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LBound(mySelection, 1) To UBound(mySelection, 1)
Set mysearch = .Range("B1:B" & lngLastRow).Find(myCounter(i, 2), lookat:=xlWhole)
If Not mysearch Is Nothing Then
mySearchRow = mysearch.Row
Else
mySearchRow = .Cells(.Rows.Count, x).End(xlUp).Row + 1        End If
For x = LBound(mySelection, 2) To UBound(mySelection, 2)
.Cells(mySearchRow, x) = myCounter(i, x)
Next x
.Cells(mySearchRow, 49) = sQuellName 'Name der Quelldatei einfügen Spalte 10 ggf. _
anpassen!
Next i
End With
In der Variante in der Datei suchst du nach "neuer Schlüssel".
Nach der Zeile müssen dann die Anpassungen gemacht werden.
Gruß
Franz
Anzeige

202 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige