Mensch immer diese Fehler..... Entschuldige bitte....

Option Explicit
Sub schreibe_in_Datei()
    Dim strDateiPfad As String
    Dim strDateiName As String
      
    strDateiPfad = ThisWorkbook.Path & "\"
    strDateiName = Dir(strDateiPfad)
      
    Do While strDateiName <> ""
        Call newRecord(strDateiPfad, strDateiName)
        strDateiName = Dir()
    Loop
  
End Sub
Sub newRecord(strPfad, strDatName)
    Dim ab As Workbook
    Dim sh As Worksheet
    Dim i As Integer
    Dim lstRow As Long
    Dim arrRange(22) As String
      
    If strDatName = ThisWorkbook.Name Or strDatName = "" Then
        Exit Sub
    End If
      
    Set wb = ThisWorkbook
    Set sh = wb.Sheets("Tabelle1")
      
    lstRow = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
      
    arrRange(0) = "B3"
    arrRange(1) = "L3"
    arrRange(2) = "B17"
    arrRange(3) = "B6"
    arrRange(4) = "L6"
    arrRange(5) = "B10"
    arrRange(6) = "L10"
    arrRange(7) = "B13"
    arrRange(8) = "L13"
    arrRange(9) = "L17"
    arrRange(10) = "K54"
    arrRange(11) = "J68"
    arrRange(12) = "N179"
    arrRange(13) = "L20"
    arrRange(14) = "B54"
    arrRange(15) = "H194"
    arrRange(16) = "H197"
    arrRange(17) = "H200"
    arrRange(18) = "H203"
    arrRange(19) = "H206"
    arrRange(20) = "H209"
    arrRange(21) = "J212"
    arrRange(22) = "H212"
      
    For i = 0 To 22
        sh.Cells(lstRow , i + 1) = GetValue(strPfad, strDatName, "Tabelle1", arrRange(i))
    Next i
  
End Sub
  
Public Function GetValue(Pfad, Dateiname, blatt, bezug) As String
  
On Error GoTo Fehler
  
Dim arg As String
  
  
If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
  
  
arg = "'" & Pfad & "[" & Dateiname & "]" & blatt & "'!" & Range(bezug).Range("A1").Address(, , xlR1C1)
  
GetValue = ExecuteExcel4Macro(arg)
  
Exit Function
  
Fehler:
GetValue = "Fehler"
  
End Function