Option Explicit
Sub Adresseneintragen()
Dim adresse As String
Dim letztezeile As Long
Dim anfrage
ActiveSheet.Cells(1, 1) = "Adressen"
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Do
letztezeile = letztezeile + 1
adresse = Application.GetOpenFilename
ActiveSheet.Cells(letztezeile, 1) = adresse
anfrage = MsgBox("Weitere Adressen eintragen?", vbYesNo)
Loop Until anfrage = vbNo
End Sub
Sub Werte_übernehmen()
Dim gesamtdatei As Object
Dim letztezeile As Long
Dim i As Long
Dim pfad As String
Dim quelle As Object
Application.ScreenUpdating = False
ActiveSheet.Cells(1, 3) = "kopierte Zeilen"
Set gesamtdatei = ActiveWorkbook
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If letztezeile > 1 Then
For i = 2 To letztezeile
pfad = ActiveSheet.Cells(i, 1)
Workbooks.Open pfad
Set quelle = ActiveWorkbook
ActiveWorkbook.Sheets("Tabelle1").Range("D40:AZ40").Copy gesamtdatei.Sheets("Tabelle1").Cells(i, 3)
gesamtdatei.Activate
quelle.Close savechanges:=False
Set quelle = Nothing
Next i
End If
Set gesamtdatei = Nothing
Application.ScreenUpdating = True
End Sub