Werte aus mehreren Dateien herausholen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
wie wäre es hiermit?
Führe diesen in Deiner Datei Erfassung.xls aus.
Pfad und erster Einfügebereich, musst Du entsprechend an Deine Bedürfnisse anpassen.

Option Explicit

Sub LeseFiles()
Dim Fso, Ordner, varDatei
Dim DateiName As String, strPfad As String
Dim objDatei As Workbook
Dim Bereich As Range
Dim iCalc As Integer

'Pfad anpassen 
strPfad = "C:\Forum"
'erster Einfügebereich anpassen 
Set Bereich = Sheets("Tabelle1").Range("A1:B1")

Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = Fso.getfolder(strPfad) 'Pfad anpassen 

With Application
 iCalc = .Calculation
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
    For Each varDatei In Ordner.Files
     If LCase(varDatei) Like "*.xls" Then
        Set objDatei = Workbooks.Open(varDatei, , True)
        Bereich.Value = objDatei.Worksheets(1).Range("A1:B1").Value
        objDatei.Close False
        Set Bereich = Bereich.Offset(1, 0)
     End If
    Next varDatei
 .Calculation = iCalc
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub

Gruß Tino

Option Explicit Sub LeseFiles() Dim Fso, Ordner, varDatei Dim DateiName As String, strPfad As String Dim objDatei As Workbook Dim Bereich As Range Dim iCalc As Integer 'Pfad anpassen strPfad = "C:\Forum" 'erster Einfügebereich anpassen Set Bereich = Sheets("Tabelle1").Range("A1:B1") Set Fso = CreateObject("Scripting.FileSystemObject") Set Ordner = Fso.getfolder(strPfad) 'Pfad anpassen With Application iCalc = .Calculation .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual For Each varDatei In Ordner.Files If LCase(varDatei) Like "*.xls" Then Set objDatei = Workbooks.Open(varDatei, , True) With objDatei.Worksheets(1) Bereich(1).Value = .Range("A1").Value Bereich(2).Value = .Range("D1").Value End With objDatei.Close False Set Bereich = Bereich.Offset(1, 0) End If Next varDatei .Calculation = iCalc .ScreenUpdating = True .EnableEvents = True End With End Sub

Sub daten_uebernehmen() Dim strFile As String Dim strPath As String Dim loZeileZielmappe As Integer Application.ScreenUpdating = False strPath = "C:\Test\" ' Pfad bitte anpassen! strFile = Dir(strPath & "*.xls") loZeileZielmappe = 1 Do While strFile "" If strFile ThisWorkbook.Name Then Cells(loZeileZielmappe, 1).Formula = "='" & strPath & "[" & strFile & "]" & " _ Tabelle1" & "'!A1" Cells(loZeileZielmappe, 2).Formula = "='" & strPath & "[" & strFile & "]" & " _ Tabelle1" & "'!D1" loZeileZielmappe = loZeileZielmappe + 1 End If strFile = Dir() Loop Range("A1:B" & loZeileZielmappe).Copy Range("A1:B" & loZeileZielmappe).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Werte aus mehreren Dateien herausholen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread