ich möchte aus einem Ordner aus allen (Excel-)Dateien den Inhalt der Zelle A1 und B1
in die Spalte Spalte A und B der Datei Erfassung.xls eintragen lassen.
Kann mir jemand weiterhelfen?
Gruß
Andres
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
Gruß Tino
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
Dieser Code funktioniert auch in Excel2007