Laufzeitfehler 1004 (???)

Sub DateienAuflisten()
Dim lngAkt           As Long
Dim rngBereich       As Range
Dim rngZelle         As Range
Dim Zelle            As String
Dim Zellinhalt       As String
Dim ZeileLesen       As String
Dim Zaehler                  As Integer
Dim ZeileSchreiben           As Integer
Dim AktivArrayfeld           As Integer
Dim beschriebeneArrayfelder  As Integer
Dim Spalte                   As Integer
'Auslese Variablen
Dim B3               As String
Dim B4               As String
Dim B5               As String
Dim B6               As String
Dim B8               As String
Dim B9               As String
Dim strArray(1 To 50) As String
Const Verzeichnis = "D:\Exceltabellen\Projekte"
With Application.FileSearch          'Hier werden alle Dateinamen aus einem Ordner in Tabelle 2 Spalte A geschrieben
.NewSearch
.LookIn = Verzeichnis
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For lngAkt = 1 To .FoundFiles.Count
Cells(lngAkt, 1) = Mid(.FoundFiles.Item(lngAkt), Len(Verzeichnis) + 1)
Next lngAkt
End With                         'bis hier werden die Dateinamen in die Zellen (A1,A2,A3,...) geschrieben
ZeileLesen = "A"                     'Startwert für Zelle wird festgelegt
ZeileSchreiben = 4                        'erste Zeile in die geschrieben werden soll
beschriebeneArrayfelder = 1
'hier sollte noch ein geeigneter schleifenanfang eingefügt werden (mir fiel keiner ein).
Do Until Zellinhalt = " "                     'Zellinhalte werden solange eingelesen bis die Zelle leer ist
Zellinhalt = Range(Zelle).Value          'Zellinhalt wird in Variable geschrieben
AktivArrayfeld = 1                       'Laufvariable für aktiviertes Arrayfeld
strArray(AktivArrayfeld) = Zellinhalt    'schreibt Zellinhalt in Array
beschriebeneArrayfelder = 1              'Laufvariable
AktivArrayfeld = AktivArrayfeld + 1      'nächstes Arrayfeld wird aktiviert
Zelle = "A" & ZeileLesen
ZeileLesen = ZeileLesen + 1
Loop
For AktivArrayfeld = 1 To beschriebeneArrayfelder
Workbooks.Open "C:\Exceltabellen\Projekte" & Zellinhalt    'Hier sollen die Zellinhalte einzeln
B3 = Range(B3).Value                                       'in das Indexblatt geschrieben werden
Worksheets("Tabelle1").Range("B" & ZeileSchreiben).Value = B3
B4 = Range(B4).Value
Worksheets("Tabelle1").Range("A" & ZeileSchreiben).Value = B4
B5 = Range(B5).Value
Worksheets("Tabelle1").Range("C" & ZeileSchreiben).Value = B5
B6 = Range(B6).Value
Worksheets("Tabelle1").Range("D" & ZeileSchreiben).Value = B6
B8 = Range(B8).Value
Worksheets("Tabelle1").Range("E" & ZeileSchreiben).Value = B8
B9 = Range(B9).Value
Worksheets("Tabelle1").Range("F" & ZeileSchreiben).Value = B9
ZeileSchreiben = ZeileSchreiben + 1
strArray(AktivArrayfeld) = ""
Next
'schleifenende
'am ende sollen noch die dateinamen aus Tab2 gelöscht werden (ist noch nicht fertig)
Columns("A").EntireColumn.Hidden = True         'Hier soll der Inhalt con Spalte A gelöscht werden
End Sub