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 ab = ThisWorkbook
Set sh = ab.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, "AVM", 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