Array muss noch sortiert werden!
25.10.2022 13:38:26
MCO
Hallo Andreas!
Das war doch umständlicher als ich dachte:
Da die Daten so umständlich aussehen hab ich sie erstmal in 4 Arrays geladen, je nach Bereich und Spaltenzuweisung.
Dann hab ich den Datenbereich gekürzt und wandle sie Dabei wieder in die ursprüngliche Formatierung.
Achtung!
Sortiert wird im Tabellenbereich, das muss evtl angepasst werden.
Sub Bereich_zu_liste()
Dim z1 As Single, z2 As Single, z3 As Single, z4 As Single, z As Single
Dim einfüg1 As Single, einfüg2 As Single, einfüg3 As Single, einfüg4 As Single
Dim bereich_1 As Range, bereich_2 As Range, cl As Range
Dim dat As Date
Set bereich_1 = Range("b4:L11")
Set bereich_2 = Range("b14:L21")
ReDim arr_A1(50)
ReDim arr_B1(50)
ReDim arr_A2(50)
ReDim arr_B2(50)
For Each cl In Application.Union(bereich_1, bereich_2).SpecialCells(xlCellTypeConstants)
dat = CDate(Replace(Mid(cl, 3, 99), " ", ".")) 'zu Datum wandeln zum Sortieren
If Not Intersect(cl, bereich_1) Is Nothing Then
If Left(cl, 1) = "A" Then
arr_A1(z1) = dat 'Mid(cl, 3, 99)
z1 = z1 + 1
Else
arr_B1(z2) = dat 'Mid(cl, 3, 99)
z2 = z2 + 1
End If
ElseIf Not Intersect(cl, bereich_2) Is Nothing Then
If Left(cl, 1) = "A" Then
arr_A2(z3) = dat 'Mid(cl, 3, 99)
z3 = z3 + 1
Else
arr_B2(z4) = dat 'Mid(cl, 3, 99)
z4 = z4 + 1
End If
End If
Next
ReDim Preserve arr_B1(z1)
ReDim Preserve arr_A1(z2)
ReDim Preserve arr_B2(z3)
ReDim Preserve arr_A2(z4)
'Hier müssten die Daten innerhalb des Array sortiert werden!
einfüg1 = 3
einfüg2 = einfüg1 - 1
einfüg3 = 23
einfüg4 = einfüg3 - 1
'Ausgabespalte noch anpassen!
arr_B1 = sortier_Das(arr_B1)
arr_A1 = sortier_Das(arr_A1)
arr_B2 = sortier_Das(arr_B2)
arr_A2 = sortier_Das(arr_A2)
For z = 1 To UBound(arr_B1)
Cells(einfüg1, "O") = "B/" & Format(arr_B1(z), "dd mmm yy"): einfüg1 = einfüg1 + 1
Next z
For z = 1 To UBound(arr_A1)
Cells(einfüg2, "P") = "A/" & Format(arr_A1(z), "dd mmm yy"): einfüg2 = einfüg2 + 1
Next z
For z = 1 To UBound(arr_B2)
Cells(einfüg3, "O") = "B/" & Format(arr_B2(z), "dd mmm yy"): einfüg3 = einfüg3 + 1
Next z
For z = 1 To UBound(arr_A2)
Cells(einfüg4, "P") = "A/" & Format(arr_A2(z), "dd mmm yy"): einfüg4 = einfüg4 + 1
Next z
End Sub
Function sortier_Das(werte As Variant) As Variant
Dim rng As Range
Set rng = Range("S5", Cells(4 + UBound(werte), "S"))
rng = WorksheetFunction.Transpose(werte)
With ActiveSheet.Sort.SortFields
.Clear
.Add2 Key:= _
rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
sortier_Das = WorksheetFunction.Transpose(rng)
rng.Clear
End Function
Gruß., MCO