Sub Daten_kopieren()
Dim Pfad_Q As String, Dateiname_Q As String, iCol As Long
Dim Pfad_Z As String, Dateiname_Z As String
Dim SourceRange As Range, DestinationRange As Range
Pfad_Q = "H:\OPTIKO\Projektantr?ge"
Pfad_Z = "H:\OPTIKO\Projektliste"
Dateiname_Z = Dir(Pfad_Z & "Zieldatei_mit_M.xlsm")
Dateiname_Q = Dir$(Pfad_Q & "*.xlsx")
While Len(Dateiname_Q)
Workbooks.Open Filename:=Pfad_Q & Dateiname_Q
iCol = Workbooks(Dateiname_Z).Sheets("Projektliste").Range("XFD2").End(xlToLeft).Offset(0, 1).Column
Set SourceRange = Workbooks(Dateiname_Q).Sheets("Projektantrag").Range("B4:B97")
Set DestinationRange = Workbooks(Dateiname_Z).Sheets("Projektliste").Cells(4, iCol).Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
DestinationRange.Value = SourceRange.Value
Application.DisplayAlerts = False
Workbooks(Dateiname_Q).Close SaveChanges:=False
Dateiname = Dir$
Wend
Application.DisplayAlerts = True
End Sub