Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 18:04:29
18.04.2024 16:33:24
Anzeige
Archiv - Navigation
1036to1040
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dateiextracte einsammeln

Dateiextracte einsammeln
05.01.2009 22:23:00
walter
Hallo und ein gutes 2009,
ich suche eine Möglichkei aus allen Dateien in einem bestimmten Verzeichnis ganz bestimmte Zellen (in jeder Datei die gleichen Zellen) darzustellen. Pro abgefragter Datei den Dateinamen in Zelle a, dann in dieser Zeile alle Wunschfelder.
Wer weiß Rat ?
Danke + Gruß
Walter

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

Betreff
Datum
Anwender
Anzeige
AW: Dateiextracte einsammeln
05.01.2009 22:28:17
Hajo_Zi
Hallo Walter,
benutze die Suche des Forums nach Application.FileSearchda findest Du bestimt was.
Gruß Hajo
AW: Dateiextracte einsammeln
05.01.2009 22:56:00
Josef
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

Anzeige
AW: Dateiextracte einsammeln
05.01.2009 23:24:38
walter
Hallo Hajo, hallo Josef,
mit Dank, wird morgen ausgetestet
Gruß
Walter

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige