automatisiertes Zusammenführen mit Extras
31.10.2018 13:32:42
Karol
Ich habe nach einigen Tagen recherche und vielen Stunden aktiven Lesens ein zusammengewürfeltes Makro gebastelt, welches ich nach und nach erweitern wollte. Nun stecke ich aber an kleinen Aufgaben fest, bei welchen ich einfach keinen Ausweg mehr sehe. Im größten Teil stammt das Vorhandene von einem Herrn Hennekes. Da es so lange her ist, kann ich nicht genau sagen wie ich es abgewandelt habe.
Nun zum eigentlichen:
Das aktuelle Makro kann die für mich relevanten Daten aus mehreren Dateien kopieren und in einer neuen Datei hintereinander einfügen.
Um das ganze aber richtig sinnhaft nutzen zu können, müsste das Makro folgendes machen:
1.Tabelle öffnen
2.leere Spalte vor A einsetzen
3.in allen Zeilen der Spalte A den Text aus B4 (nun C4) einfügen
4.alle Zeilen ab Zeile 12 kopieren, welche in der Spalte D einen Wert hinterlegt haben
5.alle Zeilen in einem Tabellenblatt sammeln
Ich habe die Schritte 2+3 bereits über die Aufzeichnung gemacht, verzweifle aber an der richtigen Position dafür im großen Makro.
Ich würde mich sehr über Unterstützung freuen.
Public Sub Dateien_zusammenfuehren()
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 über Fenster auswählen
varDateien = _
Application.GetOpenFilename("Dateien (*.xls),*.xls", False, "Bitte gewünschte BegPl-LANG _
markieren", False, True)
'unnützes Zeug sperren?
With Application
.ScreenUpdating = False 'bildflackern
.EnableEvents = False '?
.Calculation = xlCalculationManual '?
End With
'Dateien öffnen und kopieren
For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
lngLastQ = WBQ.Worksheets(1).Range("A65536").End(xlUp).Row
WBQ.Worksheets(1).Range("A12:Z" & lngLastQ).Copy _
Destination:=WBZ.Worksheets(1).Range("A" & WBZ.Worksheets(1).Range("A65536").End(xlUp).Row + _
_
_
1)
'Einfügen
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
myDocument.DrawingObjects.Delete
End Sub