Verschiedene Inputs per Makro kopieren
20.07.2020 16:36:45
Peter
ich stehe vor folgender Fragestellung:
Ich habe ca. 250 Input-Dateien (immer gleicher Aufbau) von denen ich aus einem bestimmten Worksheet (nennen wir es Worksheet2) immer die Range C10:E170 benötige. Dabei soll der Input aus den verschiedenen Dateien untereinander in ein neues Workbook in das Worksheet "Auswertung" kopiert werden.
Wichtig ist dabei noch, dass der Input in dem Worksheet ("Auswertung") erst ab der Zelle C2 reinkopiert werden soll (benötige Zeile 1 für Überschriften). In der Spalte A soll zusätzlich für die gesamte jeweilige Range ein Input einer fixen Zelle stehen (immer Zelle D4 aus dem Worksheet2) und in Spalte B immer Zeile D5 (gleiches Worksheet) - Input der Spalten A und B ändert sich aber je nach Input-Workbook.
Ich habe bereits einiges probiert (siehe unten). Mit dem folgenden Makro habe ich aber noch 3 grundsätzliche Probleme / Fragen:
1) Es wird nur 1x der Input kopiert und nicht untereinander geschrieben (erhalte nur 170 Zeilen)
2) Wie kann ich den spezifischen Input für Spalte A und B integrieren?
3) Bedeutet Range("A65536"), dass mein Auswertungssheet in Zeile 65536 stoppt? Es werden insgesamt mehr Zeilen benötigt, kann ich die Range einfach ausweiten bzw. wird diese Einschränkung überhaupt benötigt?
Vielen Dank vorab für die Hilfe!
Sub Auswertung_Aktivitaetenerhebung()
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Dim lngLastQ As Long
Set WBZ = ActiveWorkbook
'Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range("A2:IV65536").ClearContents
varDateien = _
Application.GetOpenFilename("Datei (*.xlsx),*.xlsx", 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("2").Range("A65536").End(xlUp).Row
WBQ.Worksheets("2").Range("C10:E160" & lngLastQ).Copy _
Destination:=WBZ.Worksheets("AUSWERTUNG").Range("C" & WBZ.Worksheets(1).Range("A65536").End( _
xlUp).Row + 1)
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