Sub DoCopy()
Dim Str As String
Dim arr() As String
Dim x As Integer
Dim Rng As Range
Dim wbAct As Excel.Workbook
Dim wbNeu As Excel.Workbook
Str = "X15:X21,X26:X40,AC15:AC33,AC36:AC40,D15:D20,D22:D28,D30:D34,D36:D40,I15:I18,I20:I25,I27:I33,I35:I38,I40,N15:N18,N20:N25,N27:N34,N36:N40,S15:S20,S22:S24,S27,Q28,Q29,S30,S33,Q37,AI6,N6,N8,D11,D4,D6,D8,I4:I8"
arr = Split(Str, ",")
Set wbNeu = ThisWorkbook
Set wbAct = Workbooks.Add
For x = LBound(arr) To UBound(arr)
wbAct.Sheets(1).Range(arr(x)).Value = wbNeu.Sheets(1).Range(arr(x)).Value
Next x
End Sub