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
|