Dateiextracte einsammeln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Walter,
probier mal.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DataFromFiles()
    Dim strPath As String, strFile As String, strSheet As String
    Dim lngRow As Long, lngIndex As Long, intC As Integer
    Dim varCells As Variant
    Dim a, lngResult As Long

    'Auszulesende Tabelle
    strSheet = "Tabelle1"
    'Auszulesende Zellen
    varCells = Array("A1", "B1", "F1")
    'Startzeile
    lngRow = 2

    'Verzeichnis wählen
    strPath = fncBrowseForFolder("E:\")

    On Error Resume Next
    If strPath <> "" Then
        lngResult = FileSearchINFO(a, strPath, "*.xls", True)
        If lngResult <> 0 Then
            For lngIndex = 0 To UBound(a)
                With ActiveSheet
                    .Cells(lngRow, 1) = a(lngIndex).Name
                    For intC = 0 To UBound(varCells)
                        .Cells(lngRow, 2 + intC).Formula = "='" & strPath & "\[" & _
                            a(lngIndex).Name & "]" & strSheet & "'!" & varCells(intC)
                    Next
                    .Rows(lngRow) = .Rows(lngRow).Value
                End With
                lngRow = lngRow + 1
            Next
        End If
    End If
    On Error GoTo 0
End Sub

'by J.Ehrensberger
Private Function FileSearchINFO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
        Optional ByVal SubFolders As Boolean = False) As Long

    Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object

    Set fobjFSO = CreateObject("Scripting.FileSystemObject")

    Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

    On Error Resume Next

    For Each ffsoFile In ffsoFolder.Files
        If Not ffsoFile Is Nothing Then
            If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(FileName) Then
                If IsArray(Files) Then
                    Redim Preserve Files(UBound(Files) + 1)
                Else
                    Redim Files(0)
                End If
                Set Files(UBound(Files)) = ffsoFile
            End If
        End If
    Next

    If SubFolders Then
        For Each ffsoSubFolder In ffsoFolder.SubFolders
            FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
        Next
    End If

    If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
    On Error GoTo 0
    Set fobjFSO = Nothing
    Set ffsoFolder = 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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateiextracte einsammeln

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread