Makro füllt die Zellen nicht aus!!!

Sub NamenUndKopfzeilenListen()
Dim objFSO As Object, strPfad1 As String, strPfad2 As String, i As Integer
Set objFSO = CreateObject("scripting.filesystemobject")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
.AskToUpdateLinks = False
End With
Sheets("Auswertung").Select
Sheets("Auswertung").Move After:=Sheets(Sheets.Count)
Sheets(1).Cells.Delete
With Sheets(1)
.Range("A1") = "Dateiname Ordner 1"
.Range("B1") = "Änderungsindex"
.Range("C1") = "Dateiname Ordner2 "
.Range("D1") = "Änderungsindex"
.Name = "erstellt am " & Format(Date, "dd.mm.yy") ' Hier könnte man noch Uhrzeit einsetzen ' & " " & Format(Time, "hh.mm") & " Uhr"
End With
strPfad1 = InputBox("Geben Sie bitte den ersten auszulesenden Ordner ein", Default:="R:\1_Intern\Tabellen mit Querverweisen\")
With Application.FileSearch
.LookIn = strPfad1
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
End With
For i = 1 To Application.FileSearch.FoundFiles.Count
Application.StatusBar = "Die " & i & ". von insgesamt " & Application.FileSearch.FoundFiles.Count & " Mappen im Verzeichnis " & strPfad1 & " wird eingelesen"
On Error Resume Next
Workbooks.Open Application.FileSearch.FoundFiles(i)
With ActiveWorkbook
.DisplayAlerts = False
.AskToUpdateLinks = False
End With
ThisWorkbook.Sheets(1).Range("A" & i + 1) = ActiveWorkbook.Name
ThisWorkbook.Sheets(1).Range("B" & i + 1) = ActiveWorkbook.Sheets(1).PageSetup.RightHeader
ActiveWorkbook.Close SaveChanges:=False
Next
strPfad2 = InputBox("Geben Sie bitte den zweiten auszulesenden Ordner ein", Default:="Q:\Produkte\Technik\Weissnorm\Datenblätter\")
With Application.FileSearch
.LookIn = strPfad2
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
End With
For i = 1 To Application.FileSearch.FoundFiles.Count
Application.StatusBar = "Die " & i & ". von insgesamt " & Application.FileSearch.FoundFiles.Count & " Mappen im Verzeichnis " & strPfad2 & " wird eingelesen"
Workbooks.Open Application.FileSearch.FoundFiles(i)
With ActiveWorkbook
.DisplayAlerts = False
.AskToUpdateLinks = False
End With
ThisWorkbook.Sheets(1).Range("C" & i + 1) = ActiveWorkbook.Name
ThisWorkbook.Sheets(1).Range("D" & i + 1) = ActiveWorkbook.Sheets(1).PageSetup.RightHeader
ActiveWorkbook.Close SaveChanges:=False
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
End With
Set objFSO = Nothing
Cells.Select
With Selection
.WrapText = False
End With
With Selection.Font
.Size = 8
End With
Columns("A:D").Select
Selection.Copy
Sheets("Auswertung").Select
Columns("A:A").Select
ActiveSheet.Paste
Cells(1, 6).Select
End Sub