Dateien aus Ordner einlesen

Hallo zusammen,
ich habe folgendes Problem:
Ich möchte gerne mehrere Excel-Dateien miteinander vergleichen. Dafür möchte ich auf Knopfdruck eine Userform erstellen, die mir für jede Excel-Datei eines auszuwählenden Ordners eine Checkbox erstellt, so dass ich die Dateien, die ich vergleichen möchte nur mit Häkchen versehen muss.
Soviel zur Vorgeschichte. Leider hapert es schon beim Einlesen der Dateien eines Ordners (ich benutze die "dir"-Methode). Ich möchte - wenn möglich - den Ordner über ein Fenster á la "GetOpenFilename" einlesen, in dem man sich bis zu dem gewünschten Ordner durchklicken kann, da der Pfad varieren kann. Dies funktioniert aber per "GetOpenFilename" nicht, da man hier nur Dateien, keine Ordner auswählen kann. Eine Lösung per "Inputbox" ist sicherlich denkbar, aber eher unelegant, da der Pfad recht lang ist. Hier also die Frage: "Hat jemand eine Idee oder kennt eine solche Methode?"
Im Forum habe ich leider nur Methoden gesehen, die entweder den Pfad fest vorgegeben hatten oder per "Inputbox" eingegeben bekommen.
Würde mich sehr freuen, wenn mir da jemand weiterhelfen kann.
Vielen Dank,
Philipp

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Verzeichnis() Dim ordner As FileDialog, Pfad As String Set ordner = Application.FileDialog(4) If ordner.Show = -1 Then Pfad = ordner.SelectedItems(1) MsgBox Pfad End If Set ordner = Nothing End Sub

Versuch mal den Code auf Deine Bedürfnisse anzupassen oder übernimm einfach den Code.
https://www.herber.de/bbs/user/24613.xls

'############################################################################################'
'             Die folgenden Makros durchsuchen einen Ordner und seine Unterordner            '
'                     nach xls-Dateien. Der Ordner kann ausgewählt werden.                   '
'   Aus den gefundenen Dateien wird der Wert aus der Zelle, die in E2 eingetragen ist und    '
'         aus der Tabelle, deren Namen in E1 enthalten ist, in Spalte C eingetragen.         '
'                                                                                            '
'                Teile des Makros Dateisuche und der Function GetDirectory                   '
'                      stammen aus dem Internet - Herkunft unbekannt.                        '
'############################################################################################'

'############################################################################################'
'Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.'
Public Type BROWSEINFO                                                                       '
     hOwner As Long                                                                          '
     pidlRoot As Long                                                                        '
     pszDisplayName As String                                                                '
     lpszTitle As String                                                                     '
     ulFlags As Long                                                                         '
     lpfn As Long                                                                            '
     lParam As Long                                                                          '
     iImage As Long                                                                          '
End Type                                                                                     '
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
'############################################################################################

Private z!
'Aufruf mit dem folgenden Makro
Sub Suchen()
Dim Laufwerk$, Dateien$
    'Erste Zeile, in der eine Eintragung erfolgt
    z = 2
    'Alte Eintragungen löschen
   [a2:c5000] = ""
    'Den Variablen Laufwerk und Dateien kann auch ein Wert direkt zugewiesen werden.
    Laufwerk = GetDirectory("Bitte einen Ordner wählen")    'Ersatz: ... = C:\Eigene Dateien"
    If Laufwerk = "" Then Exit Sub
    Dateien = "*.xls"
    Dateisuche Laufwerk, Dateien
    Application.StatusBar = False
End Sub
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    With bInfo
        .pidlRoot = 0&
        .lpszTitle = Msg
        .ulFlags = &H1
    End With
    x = SHBrowseForFolder(bInfo)
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function
Sub Dateisuche(Laufwerk, Dateien)
   Dim tmp, Wdhlg
    On Error Resume Next
    If Right(Laufwerk, 1) <> "\" Then Laufwerk = Laufwerk + "\"
    tmp = Dir(Laufwerk & Dateien)
    Do While Len(tmp)
        Pfad2 = Pfad(Laufwerk & tmp)
        Datei2 = Datei(Laufwerk & tmp)
        Workbooks.Open Filename:=Pfad2 & Datei2, ReadOnly:=True, UpdateLinks:=True
        Cells(z, 3).Formula = "='" & Pfad(Laufwerk & tmp) & "[" & Datei(Laufwerk & tmp) & "]" &[e1] & "'!" &[e2]
        If Cells(z, 3) <> 0 Then Cells(z, 3) = Cells(z, 3) Else Cells(z, 3) = ""
            With Application
        .Calculation = xlAutomatic
        End With
        Calculate
        Workbooks(Datei2).Close (False)
        z = z + 1
        tmp = Dir()
    Loop
    tmp = Dir(Laufwerk, vbDirectory)
    Do While Len(tmp)
       Application.StatusBar = Laufwerk & tmp
       If (tmp <> ".") And (tmp <> "..") Then
          If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
             Dateisuche Laufwerk & tmp, Dateien
             z = z - 1
             Wdhlg = Dir(Laufwerk, vbDirectory)
             z = z + 1
             Do While Wdhlg <> tmp
                Wdhlg = Dir()
             Loop
          End If
       End If
       tmp = Dir()
    Loop
   On Error GoTo 0
   Application.StatusBar = False
End Sub
Function Datei(Wert As String) As String
Do While InStr(Wert, "\") <> 0
    Wert = Right(Wert, Len(Wert) - InStr(Wert, "\"))
Loop
Datei = Wert
End Function
Function Pfad(Wert As String) As String
Dim wert1$
wert1 = Wert
Do While InStr(wert1, "\") <> 0
    wert1 = Right(wert1, Len(wert1) - InStr(wert1, "\"))
Loop
Pfad = Left(Wert, Len(Wert) - Len(wert1))
End Function

Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _ ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _ ByVal hFindFile As Long, _ lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Const MAX_PATH = 260 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Sub StartList() Dim I& Dim Ordner$, Pattern$ Dim GefundeneDateien() As String ReDim GefundeneDateien(0) Ordner = "C:\temp\" Pattern = "*.xls" Call SearchFiles(Ordner, Pattern, GefundeneDateien) For I = 0 To UBound(GefundeneDateien) - 1 MsgBox (GefundeneDateien(I)) Next End Sub Sub SearchFiles(PathName$, Pattern$, FoundFileNames) Dim hFind&, hFile&, nFile& Dim FD As WIN32_FIND_DATA If Right(PathName, 1) <> "\" Then PathName = PathName & "\" hFile = FindFirstFile(PathName & Pattern, FD) If hFile > 0 Then FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName) ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1) Do nFile = FindNextFile(hFile, FD) If nFile > 0 Then FoundFileNames(UBound(FoundFileNames)) = ClearFileName(FD.cFileName) ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1) End If Loop While nFile <> 0 End If FindClose hFile End Sub Function ClearFileName(CDat) Dim X& X = InStr(1, CDat, Chr$(0)) If X > 0 Then ClearFileName = Trim$(Left$(CDat, X - 1)) Exit Function End If ClearFileName = "" End Function

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien aus Ordner einlesen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread