Sub OrderMatcher()
Dim Source As String
Dim StrFile As String
Const csPath As String = "C:\Users\Maximilian\Documents\Studium\Bachelor Arbeit\Data\Aggr_Orders_Match\"
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Source = "C:\Users\Maximilian\Documents\Studium\Bachelor Arbeit\Data\"
StrFile = Dir(Source)
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir()
Sheets.Add After:=ActiveSheet
Windows("Order_Matcher.xlsm").Activate
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows(StrFile).Activate
ActiveSheet.Paste
Worksheets(1).Activate
Range("A1").Select
Range(Selection, Selection.End(xlLeft)).Select
Selection.Copy
Worksheets(2).Activate
Range("A1").Paste
ActiveCell.Columns("A:Y").EntireColumn.Select
ActiveCell.Columns("A:Y").EntireColumn.EntireColumn.AutoFit
MName = Workbook.Name
Worksheets(2).Name = MName
MDir = ActiveWorkbook.Path
ActiveWorkbook.SaveAs Filename:=csPath & MName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close savechanges:=True
Loop
Application.ScreenUpdating = True
End Sub
Vielen Dank für die Hilfe