|
Super danke das funktioniert Perfekt nach kleiner anpassung!!
Ine Frage hätte ich noch. Mit jedem Klick wird ja der inhalt jeder Excel datei Kopiert die sich im Ordner befindet. Wie entferne Ich im nachhinein bei zweifachem durchlauf die doppelten Einträge?
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
|