|
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).
Exemplarisch so:
Datum Bereich Verantwortlich
12.08.16 DAT Müller
12.08.16 DAT Müller
12.08.16 DAT Müller
12.08.16 DAT Müller
12.08.16 DAT Müller
Die Idee war, dass das Makro die eingefügten Zeilen zählt und so oft die jeweilige Zelle untereinander kopiert. Das klappt aber nicht, er zählt nicht.
Hier den code, den ich bereits habe (Erstmal probiert für die eine Zelle):
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 = "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 'Hier geht es nicht weiter
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
|