Per Makro sollen Dateien nach einem Dateifilter aus einem bestimmten Verzeichnis eingelesen werden.

Die Dateiliste beginnt im Bereich A4:B4
In "B1" steht das Verzeichnis (z.B. "C:\Daten"),
in "B2" der Dateifilter (z.B. "*.xls")
(wird der Dateifilter auf *.* gesetzt, werden alle Dateien aus dem Verzeichnis eingelesen!)
Steht eine korrekte Verzeichnisangabe in "B1", werden die Daten kommentarlos unter Berücksichtigung des Filters in "B2" eingelesen
Ist "B1" leer oder existiert das angegebene Verzeichnis nicht (Schreibfehler u.Ä.) wird ein Dateibrowser geöffnet und mittels diesem kann ein Verzeichnis ausgewählt werden.

VBA-Entwicklungsumgebung öffnen und zwei Module einfügen

In das erste Modul folgenden Code eintragen:

Option Explicit

Sub DateienEinlesen()
Dim arrOrdner As Variant
Dim iOrdner As Integer, x As Integer
Dim sVerzeichnis As String, sDatei As String, sFilter As String
Dim rStartzelle As Range, rEinfuegezelle As Range
  sVerzeichnis = Range("B1").Value
   If sVerzeichnis = "" Then Goto Abfrage
    If Right(sVerzeichnis, 1) = "\" Then
     sVerzeichnis = Left(sVerzeichnis, Len(sVerzeichnis) - 1)
    End If
   arrOrdner = fncFolders(sVerzeichnis)
  For iOrdner = UBound(arrOrdner) To 1 Step -1
 If fncIfFolderExists(CStr(arrOrdner(iOrdner))) Then
  Else
   Goto Abfrage
 End If
   Next iOrdner
    sVerzeichnis = sVerzeichnis
     If Right(sVerzeichnis, 1) <> "\" Then
      sVerzeichnis = sVerzeichnis & "\"
     End If
    Goto Weiter
Abfrage:
Dim sMsg As String
sMsg = "Wählen Sie bitte einen Ordner aus:"
sVerzeichnis = getdirectory(sMsg)
   If sVerzeichnis <> "" Then
    If Right(sVerzeichnis, 1) <> "\" Then
     sVerzeichnis = sVerzeichnis & "\"
    End If
   End If
Weiter:
sFilter = Range("b2")
Set rStartzelle = Range("b4")
sDatei = Dir(sVerzeichnis & sFilter)
While sDatei <> ""
Set rEinfuegezelle = rStartzelle.Offset(x)
rEinfuegezelle.Value = sDatei
rEinfuegezelle.Offset(0, -1) = x + 1
x = x + 1
sDatei = Dir
Wend
End Sub

Private Function fncFolders(sFolder As String) As Variant
   Dim arr() As String
   Dim iCounter As Integer, iFolder As Integer
   ReDim arr(1 To 1)
   arr(1) = sFolder
   iFolder = 1
   For iCounter = Len(sFolder) To 4 Step -1
 If Mid(sFolder, iCounter, 1) = "\" Or iCounter = 1 Then
    iFolder = iFolder + 1
    ReDim Preserve arr(1 To iFolder)
    arr(iFolder) = Left(sFolder, iCounter - 1)
 End If
   Next iCounter
   fncFolders = arr
End Function

Private Function fncIfFolderExists(sFolder As String) As Boolean
   Dim sOld As String
   sOld = CurDir
   On Error Resume Next
   ChDrive Left(sFolder, 1)
   ChDir sFolder
   If Err = 0 Then fncIfFolderExists = True
   On Error Goto 0
   ChDrive Left(sOld, 1)
   ChDir sOld
End Function


In das zweite Modul diesen Code eintragen:

Option Explicit

Option Private Module

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

Function getdirectory(Optional msg) As String
    Dim bInfo As BROWSEINFO
    Dim Path As String
    Dim r As Long, x As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(msg) Then
   bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
    Else
   bInfo.lpszTitle = msg
    End If
    bInfo.ulFlags = &H1
    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


Makro "DateienEinlesen" starten - viel Spaß