AW: Sortieren
04.05.2017 10:57:39
fcs
Hallo USER,
eine Formel-Lösung für eine solche Aufbereitung der Daten gibt es nicht.
Das entsprechende Makro würde einfacher, wenn deine Ausgangsdaten nach den drei Spalten aufsteigend sortiert wären.
Nachfolgende Lösung kommt ohne deine Zusatztabelle aus.
LG
Franz
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B23")) Is Nothing Then
Application.EnableEvents = False
Call Daten_aufbereiten(strSuche:=Range("B23").Value)
Application.EnableEvents = True
End If
End Sub
Sub Daten_aufbereiten(strSuche As String)
Dim objCol As New Collection
Dim strWert As String
Dim Zeile As Long, lngSpalte As Long, lngZiel As Long
Dim arrData
Dim arrWerte(), intWerte As Integer
Const strSep = ";" 'Trennzeichen in Hilfswerten
On Error GoTo Fehler
With Worksheets("TAB")
'Werteliste in Datenarray einlesen
Zeile = .Cells(.Rows.Count, 7).End(xlUp).Row
If Zeile >= 26 Then
arrData = .Range(.Cells(26, 7), .Cells(Zeile, 9))
Else
MsgBox "Keine Daten in Liste vorhanden"
Exit Sub
End If
End With
'Werte zum Suchbegriff (Name) suchen
intWerte = 0
For Zeile = LBound(arrData) To UBound(arrData)
If strSuche = arrData(Zeile, 1) Then
'Spalte 2 und 3 zusammenfassen, dabei auf 5 Zeichen mit Leerzeichen auffüllen _
und Zahlen mit führenden 0 darstellen - erforderlich für korrekte Sortierung.
'bei längeren Texten in Spalte 2 oder Zahlen größer 100 in Spalte 3 muss man _
anpassen
strWert = arrData(Zeile, 2) & String(5 - Len(arrData(Zeile, 2)), " ") _
& strSep & Format(arrData(Zeile, 3), "000")
'über das Collection-Objekt werden doppelte Werte übersprungen
objCol.Add strWert, Key:=strWert
intWerte = intWerte + 1
ReDim Preserve arrWerte(1 To intWerte)
arrWerte(intWerte) = strWert
End If
ResumeZeile:
Next
Set objCol = Nothing
Erase arrData
'gefundene Daten eintragen
With Worksheets("TAB")
'vorhandene Inhalte im Zielbereich löschen
lngZiel = 23
'letzte Zeile mit Daten in Spalte B
Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row
If Zeile > lngZiel Then
.Range(.Cells(lngZiel + 1, 2), .Cells(Zeile, 5)).ClearContents
End If
If intWerte > 0 Then
If intWerte > 1 Then
'Werte aus Spalte 2 und 3 sortieren
Call QuickSort(DasArray:=arrWerte)
End If
strWert = ""
For intWerte = LBound(arrWerte) To UBound(arrWerte)
'Werte am Trennzeichen wieder trennen
arrData = Split(arrWerte(intWerte), strSep)
'Prüfen, ob sich Wert in Spalte 2 geändert hat
If strWert Trim(arrData(0)) Then
'Startspalte für Einträge setzen
lngSpalte = 2
'Zähler für Zielzeile erhöhen
lngZiel = lngZiel + 2
'neuen Wer in Spalte 2 merken
strWert = Trim(arrData(0))
'Wert Spalte 2 eintragen
.Cells(lngZiel, lngSpalte) = strWert
End If
'Wert Spalte 3 eintragen
lngSpalte = lngSpalte + 1
.Cells(lngZiel, lngSpalte) = Val(arrData(1))
Next
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppelter Wert für Collection
Resume ResumeZeile
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
'Aus Herber-Archiv von Rudi Maintaire
'https://www.herber.de/forum/archiv/1276to1280/1279197_Code_optimieren_beschleunigen.html# _
1279197
Sub QuickSort(ByRef DasArray, Optional ErsteZeile, Optional LetzteZeile)
On Error Resume Next
Dim UnterGrenze As Long, OberGrenze As Long
Dim AktuellerWert, GemerkterWert As Variant
If IsMissing(ErsteZeile) Then
ErsteZeile = LBound(DasArray)
End If
If IsMissing(LetzteZeile) Then
LetzteZeile = UBound(DasArray)
End If
UnterGrenze = ErsteZeile
OberGrenze = LetzteZeile
AktuellerWert = DasArray((ErsteZeile + LetzteZeile) / 2)
Do While (UnterGrenze AktuellerWert And OberGrenze > ErsteZeile)
OberGrenze = OberGrenze - 1
Loop
If (UnterGrenze ErsteZeile) Then Call QuickSort(DasArray, ErsteZeile, OberGrenze)
If (UnterGrenze