Hallo, 

hier der Code: (wurde nun in Modul1 verschoben):

Sub export()
    'Abfrage zu der Liste und dem Sheet das nur die korrekten verwendetet werden
    'if ..
    
    Dim rng As Range
    Dim END_COLUMN As Integer
    Dim SOURCE_PATH As String
    Dim TEMPLATE_EMIH_FILE As String
    Dim FILE_FORMAT As String
    Dim TIMESTAMP As String
    Dim TEMPLATE_FIXED_ROWS As Integer
    Dim MASTER_LIST As Workbook
    Dim partList As Workbook
    
    Set rng = Selection
    END_COLUMN = 40
    SOURCE_PATH = "C:\Users\q482892\Desktop\EMIH-Liste\"
    TEMPLATE_EMIH_FILE = "em_template_de"
    FILE_FORMAT = ".xlsx"
    TIMESTAMP = Format(Now(), "yyyymmddhhmmss")
    TEMPLATE_FIXED_ROWS = 5
    Set MASTER_LIST = ActiveWorkbook
    
    'OpenWorkbook (SOURCE_PATH & "em_template_de_1.xlsx")
    'Set partList = ActiveWorkbook
    
    Dim arr() As String
    'Dim arr(0 To 3) As String
    Dim arrLength As Integer
    Dim pos As Integer
    Dim rangeArr() As Integer
    Dim rangeArrLength As Integer
    rangeArrLength = 0
    ReDim rangeArr(rangeArrLength)
        
    arr = Split(rng.Address, ",")
    'arr(0) = "$G$3:$R$15"
    'arr(1) = "$G$23"
    'arr(2) = "$2:$2"
    'arr(3) = "$7:$18"
    
    'Empty list have the length 1
    arrLength = UBound(arr) - LBound(arr) + 1
    
    For i = 0 To arrLength - 1
        'Splitting and remove all chars expect numeric value und double point(range)
        pos = InStr(arr(i), ":")
        arr(i) = Replace(arr(i), "$", "")
        arr(i) = removeAlpha(arr(i))
        rangeArrLength = UBound(rangeArr) - LBound(rangeArr) + 1
        'If entry has ja double point (range) for example "2:12"
        If pos > 0 Then
            leftValue = Split(arr(i), ":")(0)
            rightValue = Split(arr(i), ":")(1)
            diff = rightValue - leftValue
            'If entry for example "2:2" than add it
            If diff <= 0 Then
                ReDim Preserve rangeArr(rangeArrLength)
                rangeArr(rangeArrLength) = leftValue
            Else
                'Adding all range values from an entry for example "2:12"
                ReDim Preserve rangeArr(rangeArrLength + diff)
                t = 0
                For k = leftValue To rightValue
                    rangeArr(rangeArrLength + t) = k
                    t = t + 1
                    Next k
            End If
        'If entry havent't a double point for example "2"
        Else
            ReDim Preserve rangeArr(rangeArrLength)
            rangeArr(rangeArrLength) = arr(i)
        End If
    Next i
        
    'Call quickSort(rangeArr, 0, UBound(rangeArr))
         
    uniqueRange = removeDuplicatedAndFirst_n_Numbers(rangeArr, TEMPLATE_FIXED_ROWS)
                 
    For Each r In uniqueRange
        MsgBox r
        Next
        
    'FileCopy SOURCE_PATH & TEMPLATE_EMIH_FILE & FILE_FORMAT, SOURCE_PATH & TEMPLATE_EMIH_FILE & "_" & TIMESTAMP & FILE_FORMAT
    
    Set partList = Workbooks.Open(SOURCE_PATH & TEMPLATE_EMIH_FILE & "_" & "1" & FILE_FORMAT)
    MsgBox "test"
    MASTER_LIST.Activate
    
    
    t = TEMPLATE_FIXED_ROWS + 1
    For Each elem In uniqueRange
        MASTER_LIST.Worksheets("Anforderung").Rows(elem).Copy Destination:=partList.Worksheets("Anforderung").Rows(t)
        t = t + 1
        Next
    partList.Close SaveChanges:=True
            
    
    MsgBox "Finish function!"
End Sub

Public Function removeAlpha(r As String) As String
    With CreateObject("vbscript.regexp")
        .Pattern = "[A-Za-z]"
        .Global = True
        removeAlpha = .Replace(r, "")
    End With
End Function

Function removeDuplicatedAndFirst_n_Numbers(InputArray, n As Integer) As Variant
    Dim dic As Object
    Dim Key As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    For Each Key In InputArray
        If Key > n Then
            dic(Key) = 0
        End If
    Next
    removeDuplicatedAndFirst_n_Numbers = dic.keys
End Function

Sub OpenWorkbook(file As String)
  Workbooks.Open file
End Sub

Public Sub quickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then quickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then quickSort vArray, tmpLow, inHi
End Sub