Zeichen aus Zelle auslesen und speichern

Sub schreibe_in_Datei()
Dim i As Integer
fName = Dir("*.xls") 'Pfad verbessern
Call newRecord(fName)
Do
fName = Dir
Call newRecord(fName)
Loop While fName  ""
End Sub

Sub newRecord(fName)
If fName = ThisWorkbook.Name Or fName = "" Then
Exit Sub
End If
Dim ab As Workbook
Dim sh As Worksheet
Dim c As Object
Dim ze As Long
Dim fPath
Set wb = ThisWorkbook
Set sh = wb.Sheets("Tabelle1")
fPath = "" 'Pfad
ze = sh.[A65536].End(xlUp).Row + 1
Workbooks.Open Filename:=fPath & fName
w1 = fName
w2 = Sheets(1).[C40] 'Wert1
w3 = Sheets(1).[C41] 'Wert2
ActiveWorkbook.Close savechanges:=False
sh.Cells(ze, 1) = w1
sh.Cells(ze, 2) = w2
sh.Cells(ze, 3) = w3
Exit Sub
fb_find:
If Err = 91 Then
Resume Next
Else
MsgBox "Fehler Nr. " & Err & " ist aufgetreten:" & vbCr & Error
End If
End Sub