Office: (Office 2016) Sortierung

HS(V) · 27. Juli 2020

Hier nicht.

Oelis · 27. Juli 2020

super, jetzt hat es geklappt.

Vielen Dank

xlph 2.0 · 1. August 2020

Hallo,

@ HS(V)
die 2 Makros verhalten sich unterschiedlich bei doppelten "Mat"-Nummern.

@Oelis
welches Ergebnis ist erwünscht, wenn doppelte "Mat"-Nummer vorliegt, oder ist das nicht möglich?

HS(V) · 1. August 2020

Hallo xlph 2.0

Mit möglichen doppelten "Mat"-Nummern.

Code:

Sub hsv()
Dim sv, sq, i As Long, n As Long, j As Long, b As Long
sv = Tabelle1.UsedRange.Resize(, 2)
ReDim a(UBound(sv), UBound(sv))
n = 1
For i = 2 To UBound(sv)
a(0, 0) = sv(1, 1)
If sv(i, 1) "" And sv(i, 1) sq Then
j = 0
n = n + 1
End If
sq = IIf(sv(i, 1) = "", sq, sv(i, 1))
a(n - 1, 0) = sq
If sv(i, 2) "" Then
j = j + 1
a(0, j) = sv(1, 2)
a(n - 1, j) = sv(i, 2)
End If
If b < j Then b = j
Next i
Cells(1, 10).Resize(n, b + 1) = a
End Sub

Sub hsv_2()
Dim sv, sq, i As Long
Application.DisplayAlerts = False
sv = Tabelle1.UsedRange.Resize(, 2)
With CreateObject("scripting.dictionary")
For i = 1 To UBound(sv)
sq = IIf(sv(i, 1) "", sv(i, 1), sq)
.Item(sq) = IIf(sv(i, 2) = "", .Item(sq), .Item(sq) & sv(i, 2) & "|")
Next i
Cells(1, 10).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
End With
Columns(11).TextToColumns , , , , , , , , -1, "|"
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph 2.0 · 1. August 2020

Hallo HS(V),

funktioniert wenn Doppelte "MAT" direkt untereinander stehen, nicht wenn am Ende.

HS(V) · 1. August 2020

Hallo xlph 2.0.

Code:

Sub hsv_2()
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph 2.0 · 1. August 2020

Hallo HS(V),

ich weiß, das beschrieb ich bereits in #33.

Hier eine weitere Lösung mit Beachtung von doppelten "Mat":

Code:

Public Sub Transform()
Dim Data() As Variant
Dim Col As Collection

Data = Tabelle1.UsedRange.Resize(, 2)

Set Col = CollectData(Data)
Data = TransferToArray(Col)

If (Not Data) -1 Then
Tabelle2.Range("A1").CurrentRegion.ClearContents
Tabelle2.Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End If
End Sub

Private Function TransferToArray(Col As Collection) As Variant()
Dim Result() As Variant
Dim Item1 As Variant
Dim Item2 As Variant
Dim r As Long
Dim c As Long
Dim cmax As Long
If Col.Count = 0 Then Exit Function
For Each Item1 In Col
c = c + 1
For Each Item2 In Item1(1)
c = c + 1
Next
If cmax < c Then cmax = c
c = 0
Next
ReDim Result(1 To Col.Count, 1 To cmax)
For Each Item1 In Col
r = r + 1
c = c + 1
Result(r, c) = Item1(0)
For Each Item2 In Item1(1)
c = c + 1
Result(r, c) = Item2
Next
c = 0
Next
TransferToArray = Result
End Function

Private Function CollectData(Data() As Variant) As Collection
Dim i As Long
Dim Key As String
Dim Mat As String
Dim Info As String
Dim Result As New Collection

For i = LBound(Data, 1) + 1 To UBound(Data, 1)
Mat = Data(i, 1)
Info = Data(i, 2)
If Len(Mat) > 0 Then
Key = Mat
If Not KeyExists(Result, Key) Then
Result.Add Array(Key, New Collection), Key
End If
End If
If Len(Info) > 0 Then
Result(Key)(1).Add Info
End If
Next
Set CollectData = Result
End Function

Private Function KeyExists(Col As Collection, Key As String) As Boolean
On Error GoTo Proc_End
Col.Item Key
KeyExists = True
Proc_End:
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

HS(V) · 2. August 2020

Hallo,

Auch eine weitere weil es Spaß macht.
Und sehr schnell.

Code:

Sub hsv_3()
Dim sv, sq, i As Long, ii As Long, s0 As String, n As Long, s As Long, b as long
sv = Tabelle1.UsedRange.Resize(, 2)
ReDim a(UBound(sv), UBound(sv))
n = 1
For i = 2 To UBound(sv)
a(0, 0) = sv(1, 1)
s = 0
If InStr(s0, "|" & sv(i, 1) & "|") = 0 Then
If sv(i, 1) "" Then
s0 = s0 & "|" & sv(i, 1) & "|"
a(n, 0) = sv(i, 1)
For ii = i To UBound(sv)
sq = IIf(sv(ii, 1) = "", sq, sv(ii, 1))
If sq = sv(i, 1) And sv(ii, 2) "" Then
s = s + 1
a(0, s) = sv(1, 2) & " " & s
a(n, s) = sv(ii, 2)
End If
Next ii
n = n + 1
End If
End If
If s > b Then b = s
Next i
tabelle2.Cells(1).Resize(n, b + 1) = a
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph 2.0 · 2. August 2020

\@ HS(V),

das ist problematisch...
Code:

ReDim a(UBound(sv), UBound(sv))
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wollte einen Speed-Test durchführen über 30k Datensätze.
Leider kam die Fehlermeldung nicht genügend Speicher.

30.000 * 30.000 = 900.000.000 zu belegende Variant-Variablen

Das ist zuviel für meinen Arbeitsspeicher.

HS(V) · 2. August 2020

Hallo xlph 2.0

Das ist problematisch.

Das Problem kann auch darin bestehen, dass es bei 30K nicht genügend Spalten gebt.
2^14 =16384

Ich bleibe bei hsv_2().
Über 30K Datensätze:
1.234 Sek. gegenüber 2.809 Sek. mit Sub Transform().

Natürlich ist es ein netter Code von Ihnen.

WS-53 · 2. August 2020

Hallo xlph 2.0,

wie sieht denn dein 30K Testaufbau aus? Wenn du mir das mitteilst, kann ich ja mal testen, wie lange es mit Power Query dauert.

xlph 2.0 · 2. August 2020

Hallo WS-53,

nachdem mir 2 mal die Datei korrupt geworden ist, hab ich aufgegeben.

Dabei ist mir aufgefallen, das das PQM von dir die "Mat" Nummern nicht mit übernimmt wenn es keine "Info" dazu gibt. M.E. sollte alles übernommen werden.

Weitere Erkenntisse:
PQM benötigt initial recht lange, ab dem 2. Versuch ist es sehr schnell.

WS-53 · 2. August 2020

Hallo xlph 2.0,

Dabei ist mir aufgefallen, das das PQM von dir die "Mat" Nummern nicht mit übernimmt wenn es keine "Info" dazu gibt. M.E. sollte alles übernommen werden.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wurde nicht geannnt, kam in der Mustermappe nicht vor und wurde deshalb von mir nicht beachtet. Kann man aber als nicht genannte Anforderung so hinein interpretieren.

Abgesehen davon, das der TE ja nicht an einer PQ-Lösung intersssiert ist, war es aber ein leichtes, die Abfrage entsprechend anzupassen.

xlph 2.0 · 3. August 2020

Wurde nicht geannnt, kam in der Mustermappe nicht vor und wurde deshalb von mir nicht beachtet. Kann man aber als nicht genannte Anforderung so hinein interpretieren.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wenn ich eine Tabelle in eine andere Form bringe, dann erwarte ich keinen Datenverlust.

Office: (Office 2016) Sortierung

Sortierung

Sortierung

Sortierung

Sortierung

Sortierung

Sortierung - Similar Threads - Sortierung

Listbox Sortierung

Sortierung aufgrund farblicher Hinterlegung

Spalte A nach Buchstaben, dann erst nach Zahlen sortieren

Sortierung und Zusammenfassung nach Kostenstelle

Sortierung einer "Basisliste" und drei neue Listen erstellen

Neusortierung von Datenreihe nach zwei Bedingungen

ROOFSORT: Die Sortierung mit Dach