AW: im Verzeichnis aus allen Dateien Daten auslesen
08.01.2009 12:56:12
walter
Hallo Josef,
hier der Code(Modul1 unter Allgemein).
Gruß
Walter
Option Explicit
Sub DataFromFiles()
Dim objWB As Workbook, objWS As Worksheet, objWSRead As Worksheet
Dim strPath As String
Dim lngRow As Long, lngIndex As Long
Dim a, lngResult As Long
On Error GoTo ErrExit
GMS
'Verzeichnis wählen
strPath = fncBrowseForFolder("c:\")
If strPath "" Then
Set objWS = ThisWorkbook.Sheets("Datensammlung") 'Blatt in dem die Daten gesammelt werden.(Name anpassen)
lngRow = objWS.Cells(Rows.Count, 1).End(xlUp).Row + 1
lngResult = FileSearchFSO(a, strPath, "*.xls*", True)
If lngResult 0 Then
For lngIndex = 0 To UBound(a)
Set objWB = Workbooks.Open(a(lngIndex))
For Each objWSRead In objWB.Worksheets
objWS.Cells(lngRow, 1) = objWSRead.Range("b5")
objWS.Cells(lngRow, 2) = objWSRead.Range("b6")
objWS.Cells(lngRow, 3) = objWSRead.Range("b7")
objWS.Cells(lngRow, 4) = objWSRead.Range("b9")
objWS.Cells(lngRow, 5) = objWSRead.Name
objWS.Cells(lngRow, 6) = objWB.Name
lngRow = lngRow + 1
Next
objWB.Close False
Next
End If
End If
ErrExit:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & _
Err.Description, Title:="Fehler"
Set objWB = Nothing
Set objWS = Nothing
Set objWSRead = Nothing
GMS True
End Sub
Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Set mobjFSO = CreateObject("Scripting.FileSystemObject")
Set mfsoFolder = mobjFSO.GetFolder(InitialPath)
On Error Resume Next
For Each mfsoFile In mfsoFolder.Files
If Not mfsoFile Is Nothing Then
If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Files(UBound(Files)) = mfsoFile
End If
End If
Next
If SubFolders Then
For Each mfsoSubFolder In mfsoFolder.SubFolders
FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function