Problem mit dem Lesen von Laufwerken

Sub Unterverzeichnis()
Dim i As Integer
Dim strMldg As String
Dim strlen As Integer
Dim Bereich As Range
Dim Pfad As String
Application.ScreenUpdating = False
strMldg = InputBox("Welches Verzeichnis soll gelesen werden", "Festlegung des Verzeichnises")
Pfad = strMldg & ":\"
Pfad = "F:\"
On Error Resume Next
ChDir Pfad
With Application.FileSearch
.NewSearch
.LookIn = Pfad
.SearchSubFolders = True
.Filename = "*.*"
.FileType = msoFileTypeAllFiles
'Identifikation der Länge des längsten Dateinamens
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
If Len(.FoundFiles(i)) > strlen Then strlen = Len(.FoundFiles(i))
Next i
'Neues Blatt einschieben und benennen
Worksheets.Add After:=Worksheets(Worksheets.Count)
strMldg = InputBox("Wie soll die neue CD heissen", "Abfrage des Namens", Format(Now, "yymmddhhmm"))
ActiveSheet.Name = strMldg
Worksheets("Cockpit").Activate
Range("A1").Select
While ActiveCell.Offset(1, 0).Value <> ""
Debug.Print ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Select
Wend
ActiveCell.Offset(1, 0).Value = strMldg
Debug.Print ActiveCell.Offset(1, 0).Value & "   " & strMldg
Worksheets(strMldg).Activate
'Worksheets("CD060122_02").Activate
Cells(1, 1).Activate
ActiveCell.Value = "Gelesener Pfad = " & Pfad
Set Bereich = Range(Cells(2, 1), Cells(.FoundFiles.Count, 1))
Bereich.Select
Selection.ColumnWidth = strlen
For i = 1 To .FoundFiles.Count
strMldg = .FoundFiles(i)
ActiveCell.Offset(i - 1, 0).Value = Mid(strMldg, 4, Len(strMldg) - 3)
'ActiveCell.Offset(i - 1, 1).Value = CurDir
'strMldg = strMldg & Chr(10) & .FoundFiles(i)
Next i
'ActiveCell.Offset(i + 1, 0).Value = ActiveWorkbook.Name
'ActiveCell.Offset(i + 1, 1).Value = ActiveWorkbook.Path
Else
'MsgBox "Es wurden keine Dateien gefunden", vbCritical, "keine Dateien"
Exit Sub
End If
End With
Columns("A:A").Select
Selection.Sort key1:=Range("A1"), order1:=xlAscending, header:=xlYes
Worksheets("Cockpit").Activate
Application.ScreenUpdating = True
End Sub