Daten aus mehreren Dateien kopieren
08.02.2019 10:54:10
Roman
ich verwende folgenden angepassten Code. Er funktioniert an sich, aber das Kopieren der Daten _
dauert bei vielen Dateien mehrere Minuten. Hatte vorher einen Code, der sehr schnell war, aber _ die Formate nicht übernommen hat. Könnt ihr euch den Code mal anschauen, ob da etwas nicht korrekt ist bzw. ob man den anpassen kann?
Sub Daten_aus_Protokollen_kopieren()
Dim StatusCalc
'Makrobremsen lösen - Am beginn eine sMakros
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Const sXlsPath = "C:\Users\admin\Desktop\Test\" 'Pfad mit Dateien angeben
Const iStartZeile = 4
Const iStartSpalte = 1
Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29"
Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As _
Worksheet
Dim aCells As Variant, iNextLine As Long, i As Integer
Set oWks0 = ThisWorkbook.ActiveSheet
aCells = Split(Zellen, ","): iNextLine = iStartZeile
Set oFso = CreateObject("Scripting.FilesystemObject")
ActiveSheet.Range("A4:I1000").ClearContents
For Each oFile In oFso.GetFolder(sXlsPath).Files
If LCase(oFso.GetExtensionName(oFile.Name)) = "xlsx" Then
If ThisWorkbook.Path oFile.Name Then
Set oWkb1 = Workbooks.Open(oFile.Path)
Set oWks1 = oWkb1.Sheets(1)
For i = 0 To UBound(aCells)
oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells( _
_
_
_
i))).Value
Next
oWkb1.Close False
iNextLine = iNextLine + 1
End If
End If
Next
Beenden: 'Sprungadresse zum Beenden diese Makros - nicht mit Exit
Sub arbeiten!!
'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub