AW: Array aus Application ausgeben
15.04.2020 16:01:35
Thorsten
Hallo Dieter,
Danke für deine Antwort.
Anbei erstmal der Sortier- und Duplikatentfernungscode.
Für ein Beispielfile würde ich etwas länger brauchen.
Deshalb hier kurz ein Beispiel:
J I
2,5 4,5
2,1 5,3
4,5 3,7
2,2 5,1
2,7 6,2
2,1 3,7 (hier jeweils ein Duplikat, dass ebenfalls über Arraysort entfernt wird)
Gewünschtes Ergebnis(funktioniert auch soweit):
3,7 4,5 5,1 5,3 6,2 (HIER IN DER HORIZONTALEN SETZT ER PLÖTZLICH PUNKTE STATT KOMMAS)
2,1
2,2
2,5
2,7
4,5
Function ArraySort(vArr As Variant) As String
'Sortieren eines einstelligen Arrays über eine Collection
Dim i As Long, oCol As New Collection
For i = 1 To UBound(vArr)
CollectionAddItem oCol, vArr(i, 1)
Next i
For i = 1 To oCol.Count
ArraySort = ArraySort & oCol.Item(i) & ","
Next i
End Function
Function CollectionAddItem(oCol As Collection, ByVal sItem As String, Optional iPos As Integer, _
Optional ByVal vKey As Variant) As Long
'Function fügt einen Eintrag sortiert in eine Collectionsammlung ein
Dim nStart As Long, nEnd As Long, iItem As Double
If Trim$(sItem) = "" Then Exit Function
sItem = Replace(sItem, ",", ".")
iItem = Val(sItem)
With oCol
If iPos 0 Then .Add sItem, vKey, 1: Exit Function
If .Count iItem Then
.Add sItem, vKey, 1 'an 1. Position einfügen
'jetzt mit letzten Eintrag vergleichen
ElseIf Val(.Item(1)) = iItem Or .Item(.Count) = sItem Then
Exit Function
ElseIf Val(.Item(.Count)) iItem: nEnd = CollectionAddItem
Case Is
Ich habe es auch soweit, dass es funktioniert. Das ist aber womöglich unschön gelöst:
Private Sub LAENGEholen_Click()
Dim lArr() As Variant, sArr() As String
Dim dArr() As Variant, tArr() As String, cArr() As String
Dim i As Long
'Länge holen
Range(Cells(5, "L"), Cells(1048576, "XFD")).ClearContents
Range(Cells(5, "L"), Cells(1048576, "XFD")).Interior.Color = RGB(255, 255, 255)
Range(Cells(5, "L"), Cells(1048576, "XFD")).Borders.Color = RGB(255, 255, 255)
lArr = Range("J5:J" & Range("A65536").End(xlUp).Row).Value
sArr = Split(ArraySort(lArr), ",")
Cells(6, "L").Resize(UBound(sArr), 1) = Application.Transpose(sArr)
'Durchmesser holen
dArr = Range("I5:I" & Range("A65536").End(xlUp).Row).Value
tArr = Split(ArraySort(dArr), ",")
For i = 0 To UBound(tArr)
tArr(i) = Replace(tArr(i), ".", ",")
Next i
Cells(5, "M").Resize(1, UBound(tArr)) = tArr
End Sub