Hallo,

da, aus mir unerklärlichen Gründen, der vorherige Thread als abgeschlossen markiert ist, starte ich einen neuen. (Sorry aber es gab zwischenzeitlich massive Probleme, deshalb die vier Post in 2 Sekunden:)

Mein Ziel ist es, Zellen in einer Liste zu markieren, eine weiteres Workbook automatisiert zu öffnen. In das neue Workbook sollen die neuen markierten Zellen kopiert werden. Leider geschiehts nach dem Öffnen des zweiten Workbooks gar nichts mehr. Nicht mal ein simples MsgBox "Test" funktioniert. Es kommt zu keiner Fehlermeldung oder sonstigem.

Zur Info: Der Code befindet sich in einer PERSONAL.XLSB und mittlerweile unter Modul1. Dazu arbeite ich erst seit wenigen Tagen mit VBA.

Code:

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"  '  <- Dies wird nicht mehr ausgegeben und der Rest auch nicht mehr dann
    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

Ich hoffe ihr könnt mir Tipps geben.

mfg Franz