Ordner auslesen und Zellen kopieren

Private Sub CommandButton1_Click()
Dim strFTyp As String, _
strOrdner As String, _
strSF As Byte, _
strFile As String, _
strName As String, _
FS As FileSearch, _
i As Integer, z As Integer, n As Integer, _
wbkVV As Workbook, _
wshVV As Worksheet, _
wshFiles As Worksheet, _
rngFind As Range, iZähler As Integer
Application.ScreenUpdating = False
strFTyp = "*.xls"
strOrdner = ThisWorkbook.Path
Set FS = Application.FileSearch
With FS
.LookIn = strOrdner
.Filename = "*" & strFTyp
.SearchSubFolders = True
If .Execute > 0 Then
Set wshFiles = Sheets(1)
For i = 1 To .FoundFiles.Count
If .FoundFiles(i)  ThisWorkbook.Path & "\" & ThisWorkbook.Name Then
n = wshFiles.Cells(65536, 1).End(xlUp).Row + 1
strFile = .FoundFiles(i)
Set wbkVV = Workbooks.Open(Filename:=.FoundFiles(i), IgnoreReadOnlyRecommended:=True)
Set wshVV = wbkVV.Sheets(1)
strName = wbkVV.Name
With wshFiles.Rows(n)
.Cells(1) = wshVV.Range("J19")
.Cells(2) = wshVV.Range("I21")
.Cells(3) = wshVV.Range("A1")
.Cells(6) = wshVV.Range("A9")
.Cells(7) = wshVV.Range("A20")
.Cells(8) = wshVV.Range("B26")
.Cells(9) = strName
End With
wbkVV.Close False
End If
Next i
End If
End With
wshFiles.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Im voraus schon mal besten Dank für eure Hilfe
Liebe Grüße
Manu