Mehrere Dateien in einem Ordner öffnen
27.08.2019 17:18:36
Stefan
ich bräuchte mal eure Hilfe. Ich möchte gerne Daten aus mehreren Dateien (die alle die selbe Struktur haben und in einem Ordner liegen) zusammen rechnen und in eine neu erstellte Zieldatei einfügen. Das Funktioniert soweit auch, nur würde ich gerne vermeiden das man per Application.GetOpenFilename die Dateien auswählen muss. Ich hätte es gerne so das man einfach den Pfad zum Ordner in eine InputBox eingibt und dann der weitere Code ausgeführt wird. Das funktioniert so mit mienem Code leider nicht. Ich kriege dann diese Meldung: "Typen Unverträglich" und der Debugger markiert die LBound funktion
Mein Code sieht wie folgt aus. (Seid nicht zu forsch mit meinem Code, dass ist das erste mal das ich mit VBA arbeite hahaha)
Sub LiabillityZusammenführenV4()
Dim pfad As Variant
Dim i As Integer
Dim Quelldatei As Worksheet
Dim Zieldatei As Workbook
Dim time1 As Double
Dim template1 As Variant
template1 = InputBox("Gib den Pfad incl. Namen und Endung des templates ein")
pfad = InputBox("Gibt den Pfad zum Ordner an in dem alle Dateien liegen")
'Bei Abbruch ist der Rückgabewert = False (Typ: "Boolean")
If TypeName(pfad) = "Boolean" Then
Exit Sub
End If
'Zieldatei festlegen
Set Zieldatei = Workbooks.Add(template1)
'keine aktualisierung des Displays
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'Unterdrückung der
Meldung von "Es befindet sich..."
time1 = Timer
'Öffnen der Dateien
For i = LBound(pfad) To UBound(pfad)
Set Quelldatei = Workbooks.Open(pfad(i)).Worksheets(2)
With Quelldatei
.Range("C6:Z74").Copy
Zieldatei.Worksheets(2).Range("C6").PasteSpecial _
Paste:=xlPasteSpecialOperationAdd, Operation:=xlAdd, SkipBlanks:=True, _
Transpose:=False
.Parent.Close False
End With
Next i
Debug.Print "Range2Array braucht " & Timer - time1 & " Sekunden"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If MsgBox("Soll die Datei Schreibgeschützt gespeichert werden?", vbYesNo) = vbYes Then
ActiveWorkbook.SaveAs ReadOnlyRecommended:=True
ActiveWorkbook.Close
Else
End If
End Sub
LG,
Stefam