PDA

Vollständige Version anzeigen : Zellen aus mehreren Dateien mehrfach untereinander kopieren


MarkDroz
27.09.2016, 10:59
Liebes Forum, ich komme mit meinem Problem einfach nicht weiter und hoffe, dass hier vielleicht jemand einen guten Tipp hat. Es geht um folgendes: Ich möchte aus mehreren Dateien, die gleich aufgebaut sind, die eingetragenen Daten kopieren und in einer Konsolidierungsdatei untereinander schreiben/kopieren. Das Kopieren der grossen Datensätze (Zeilen) ist kein Problem und klappt schon. Was aber Probleme breitet ist, dass in jeder Datei gibt es 3 Zellen (immer an der gleichen Stelle), die ich jeweils so oft untereinander kopiert haben möchte, wie es Zeilen gibt (die vorher rein kopiert worden sind von einem Blatt). Ich hab es anbei exemplarisch als Bild erstellt.http://de.share-your-photo.com/img/5026812f35.jpg
Hier der Code den ich bereits habe

Private Sub CommandButton1_Click()
'Code für ein allgemeines Modul
'********************************
'Autor: Jürgen Hennekes
'********************************
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Dim numberrows As Integer
Dim countrows As Integer
Const datecell As String = "I2"
Const bucketcell As String = "N5"
Const ownercell As String = "S5"


Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("C2:IV65536").ClearContents

varDateien = _
Application.GetOpenFilename("Datei (*.xl*),*.xls", False, "Bitte gewünschte Datei(en) markieren", False, True)

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
lngLastQ = WBQ.Worksheets(1).Range("C65536").End(xlUp).Row
WBQ.Worksheets(1).Range("C12:X" & lngLastQ).Copy
WBZ.Worksheets(1).Range("C" & WBZ.Worksheets(1).Range("C65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
'Kopiert die Daten aus dem Template ohne Formatierung
WBQ.Worksheets(1).Range(datecell).Copy
WBZ.Worksheets(1).Range("Y" & WBZ.Worksheets(1).Range("X65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
'Kopiert das Datumsfeld, update datum
WBQ.Worksheets(1).Range(bucketcell).Copy
WBZ.Worksheets(1).Range("Z" & WBZ.Worksheets(1).Range("X65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
'Kopiert das Bucket
WBQ.Worksheets(1).Range(ownercell).Copy 'Kopiert den Owner
countrows = WBQ.Worksheets(1).Range("X65536").End(xlUp).Row.Count
countrows = numberrows
For i = 2 To numberrows
WBZ.Worksheets(1).Range("AA" & i).PasteSpecial Paste:=xlPasteValues
i = (i - 1) + 1
Next

WBQ.Close
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64

Exit Sub

errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub

MarkDroz
27.09.2016, 14:42
Ich hab es jetzt lösen können. Aber hat noch jemand einen Tipp, wie ich es optimieren könnte. Bei 2 testdateien dauert es schon ziemlich lang, wenn es nun 50 sind, sollte es auch noch laufen.

Private Sub CommandButton1_Click()

On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Dim numberrows As Integer
Dim countrows As Integer
Const datecell As String = "I2"
Const bucketcell As String = "N5"
Const ownercell As String = "T5"


Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("C2:IV65536").ClearContents

varDateien = _
Application.GetOpenFilename("Datei (*.xl*),*.xls", False, "Bitte gewünschte Datei(en) markieren", False, True)

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
lngLastQ = WBQ.Worksheets(1).Range("C12").End(xlDown).Row
WBQ.Worksheets(1).Range("C12:Y" & lngLastQ).Copy
WBZ.Worksheets(1).Range("C" & WBZ.Worksheets(1).Range("C65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
'Kopiert die Daten aus dem Template ohne Formatierung
lngLastQ = lngLastQ - 10
For i = 2 To lngLastQ
WBQ.Worksheets(1).Range(datecell).Copy
WBZ.Worksheets(1).Range("AA" & WBZ.Worksheets(1).Range("AA65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
'Kopiert das Datumsfeld, update datum
WBQ.Worksheets(1).Range(bucketcell).Copy
WBZ.Worksheets(1).Range("AB" & WBZ.Worksheets(1).Range("AB65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
'Kopiert das Bucket
WBQ.Worksheets(1).Range(ownercell).Copy 'Kopiert den Owner
WBZ.Worksheets(1).Range("AC" & WBZ.Worksheets(1).Range("AC65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
i = (i - 1) + 1
Next


WBQ.Close
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64

Exit Sub

errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub

aloys78
27.09.2016, 15:06
Hallo Mark,
Bei 2 testdateien dauert es schon ziemlich lang
Was heisst das konkret ?

Kannst Du die 2 Testdateien hier mal zur Verfügung stellen !?

Gruß
Aloys

MarkDroz
27.09.2016, 15:22
Hi Aloys,
Schwierig, das sind ziemlich sensible Daten.
Aber ich hab mal eine datei anonymisiert. Die kann man dann einfach mehrfach kopieren und damit testen.

Also ich hab es jetzt mit 4 Dateien ausprobiert, 2x mit 350 zeilen und 2 x mit 150 zeilen gefüllt. Er hat es zwar gemacht aber zwischendurch kam "not responding".

Die Datei ist zu groß zum uploaden, hier der link:
https://ufile.io/5b722

Gruß

aloys78
27.09.2016, 21:21
Hallo Mark,

mein Lösungsvorschlag.
Schwerpunkt war das Kopieren in AA:AC.
Option Explicit

Private Sub CommandButton1_Click()

On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Dim numberrows As Integer
Dim countrows As Integer
Const datecell As String = "I2"
Const bucketcell As String = "N5"
Const ownercell As String = "T5"
Dim i As Long

Dim sZeile As Long 'Startzeile in Ziel
Dim eZeile As Long 'Endezeile in Ziel

Set WBZ = ThisWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("C2:IV65536").ClearContents

varDateien = _
Application.GetOpenFilename("Datei (*.xl*),*.xls", False, "Bitte gewünschte Datei(en) markieren", False, True)

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
ThisWorkbook.Activate
lngLastQ = WBQ.Worksheets(1).Range("C12").End(xlDown).Row

With WBZ.Worksheets(1)
sZeile = .Cells(Rows.Count, "C").End(xlUp).Row + 1 'Startzeile Ziel (vor dem Kopieren)
WBQ.Worksheets(1).Range("C12:Y" & lngLastQ).Copy
.Range("C" & sZeile).PasteSpecial Paste:=xlPasteValues
eZeile = .Cells(Rows.Count, "C").End(xlUp).Row 'Endezeile Ziel (nach dem Kopieren)
WBQ.Worksheets(1).Range(datecell).Copy .Range("AA" & sZeile)
.Range("AA" & sZeile).AutoFill Destination:=.Range("AA" & sZeile & ":AA" & eZeile), Type:=xlFillCopy
WBQ.Worksheets(1).Range(bucketcell).Copy .Range("AB" & sZeile)
.Range("AB" & sZeile).AutoFill Destination:=.Range("AB" & sZeile & ":AB" & eZeile)
WBQ.Worksheets(1).Range(ownercell).Copy .Range("AC" & sZeile)
.Range("AC" & sZeile).AutoFill Destination:=.Range("AC" & sZeile & ":AC" & eZeile)
End With

Next lngAnzahl

WBQ.Close

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With


MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64

Exit Sub
Gruß
Aloys

MarkDroz
28.09.2016, 09:13
Hi Aloys,

vielen Dank erstmal für deine Hilfe!

Ich hab deinen Code ausprobiert, er funktioniert.
Es geht auch viel schneller, das ist schon einmal super.
Aber es gibt noch ein paar Probleme:
- Er kopiert bei den 3 Zeilen am Ende die Formate mit (wahrscheinlich das kleinste Problem)
- Die Zahlenwerte ändern sich dabei. Bsp. hab ich in einer Zelle Top350 zu stehen. jetzt zieht er die Werte runter wobei die Zahl sich erhöht, also Top351, Top352, usw...
- Die Dateien, aus denen er die Werte kopiert hat, sind geöffnet (heissen dann nur excel).

Hast du dafür noch Ideen?

VG

aloys78
28.09.2016, 17:15
Hallo Mark,
- Er kopiert bei den 3 Zeilen am Ende die Formate mit (wahrscheinlich das kleinste Problem)
Bei Datum habe ich das Zahlenformat gelassen.
- Die Zahlenwerte ändern sich dabei. Bsp. hab ich in einer Zelle Top350 zu stehen. jetzt zieht er die Werte runter wobei die Zahl sich erhöht, also Top351, Top352, usw...
müßte jetzt ok sein !
- Die Dateien, aus denen er die Werte kopiert hat, sind geöffnet (heissen dann nur excel).
Die Dateien werden jetzt geschlossen.
Aber was meinst Du mit der rot markierten Anmerkung ?

Nachstehend eine neue Code-Version.

Gruß
Aloys
Option Explicit

Private Sub CommandButton1_Click()
'Version V2 vom 28.09.2016

On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Dim numberrows As Integer
Dim countrows As Integer
Const datecell As String = "I2"
Const bucketcell As String = "N5"
Const ownercell As String = "T5"
Dim i As Long

Dim sZeile As Long 'Startzeile in Ziel
Dim eZeile As Long 'Endezeile in Ziel

Set WBZ = ThisWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("C2:IV65536").ClearContents

varDateien = _
Application.GetOpenFilename("Datei (*.xl*),*.xls", False, "Bitte gewünschte Datei(en) markieren", False, True)

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
ThisWorkbook.Activate
lngLastQ = WBQ.Worksheets(1).Range("C12").End(xlDown).Row

With WBZ.Worksheets(1)
sZeile = .Cells(Rows.Count, "C").End(xlUp).Row + 1 'Startzeile Ziel (vor dem Kopieren)
WBQ.Worksheets(1).Range("C12:Y" & lngLastQ).Copy
.Range("C" & sZeile).PasteSpecial Paste:=xlPasteValues
eZeile = .Cells(Rows.Count, "C").End(xlUp).Row 'Endezeile Ziel (nach dem Kopieren)
.Range("AA" & sZeile) = WBQ.Worksheets(1).Range(datecell)
.Range("AA" & sZeile).NumberFormat = "dd.mm.yyyy"
.Range("AA" & sZeile).AutoFill Destination:=.Range("AA" & sZeile & ":AA" & eZeile), Type:=xlFillCopy
.Range("AB" & sZeile) = WBQ.Worksheets(1).Range(bucketcell)
.Range("AB" & sZeile).AutoFill Destination:=.Range("AB" & sZeile & ":AB" & eZeile), Type:=xlFillCopy
.Range("AC" & sZeile) = WBQ.Worksheets(1).Range(ownercell)
.Range("AC" & sZeile).AutoFill Destination:=.Range("AC" & sZeile & ":AC" & eZeile), Type:=xlFillCopy
End With
WBQ.Close

Next lngAnzahl

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Range("A1").Select


MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64

Exit Sub

errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub