VBA Sortieren

Sub Eindeutige_Daten() Dim rng As Range Dim InputRng As Range, OutRng As Range Set dt = CreateObject("Scripting.Dictionary") xTitleId = "Eindeutige Daten" Set InputRng = Application.Selection Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8) Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8) For Each rng In InputRng If rng.Value "" Then dt(rng.Value) = "" End If Next OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.Keys) '** Zelladresse in Spalten- und Zeilenangabe trennen Dim wert() As String wert = Split(OutRng.Address, "$") letztezeile = ActiveSheet.Cells(1048576, wert(1)).End(xlUp).Row With ActiveWorksheet.Sort .SetRange Range(OutRng & ":" & wert(1) & letztezeile) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Calculate End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Eindeutige_Daten() Dim rng As Range Dim InputRng As Range, OutRng As Range Set dt = CreateObject("Scripting.Dictionary") xTitleId = "Eindeutige Daten" Set InputRng = Application.Selection Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8) Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8) For Each rng In InputRng If rng.Value "" Then dt(rng.Value) = "" End If Next OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.Keys) '** Zelladresse in Spalten- und Zeilenangabe trennen Dim wert() As String wert = Split(OutRng.Address, "$") letztezeile = ActiveSheet.Cells(1048576, wert(1)).End(xlUp).Row With ActiveWorkbook.ActiveSheet.Sort .SetRange ActiveWorkbook.ActiveSheet.Range(OutRng & ":" & wert(1) & letztezeile) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Calculate End Sub

ich habe ja meinen ganzen Code hier hochgeladen, und dann tröpfchenweise angepasst.
ich kann mich ja nur von Problem zu Problem hangeln.
Ich habe das Makro aufgezeichnet und mir ist das aufgefallen dass nicht vor meinem Code stand, also habe ich das eingefügt und den Bereich durch meine Variablen ergänzt, so wie in der vorherigen Nachricht geschrieben.
Das hat mich eben dann zum nächsten Fehler gebracht.
Mir wäre es, zumindest im Moment, auch lieber wenn ich gleich nach der 1. Antwort einen funktionierenden Code gehabt hätte.
Ich habe auch nichts gegen das herantasten, denn dann verstehe ich evtl etwas mehr , aber genau wegen dem "tröpfechenweise" habe ich den gesamten Code gleich am Anfang gepostet, so dass jeder seine Lösung testen könnte und evtl kein Fehler mehr auftaucht.

Hallo zusammen,
Ich verstehe weiterhin nicht, warum es aus eine Liste von Werte (sagen wir 10 einzelne) nur die eindeutige Werte gelesen werden (es sind womöglich weniger als in der originale Liste. Vor allem die leere Zelle werden ausser acht gelassen. Wir sagen, wir hätten nur noch 7), irgendwo abgelegt und darauf sortiert, aber dann auf dem gesamten Umfang der originale Liste.
Irgendwie ergibt dieses Verfahren für mich sehr wenig sinn.
Vielleicht könnte die Datei (verfremdet, es interessiert uns nur eine sehr kleine Teil davon) helfen, das gesamt zu verstehen.
Blind würde folgende Vorschlag einreichen:


Sub Eindeutige_Daten()
Dim rng As Range
Dim InputRng As Range
Dim OutRng As Range
Dim Spalte() As String
Set InputRng = Application.InputBox("Range :", xTitleId, Selection.Address, Type:=8)
Set OutRng = Application.InputBox("Output to (single cell):", xTitleId, Type:=8)
'stellt sicher, dass OutRng nur eine Zelle ist.
Set OutRng = OutRng.Cells(1)
'aber eigentlich wäre vielleicht folgende Verfahren besser
'    Set OutRng = Intersect(InputRng.Rows(1).EntireRow, OutRng.Cells(1).EntireColumn)
'Aufnahme der eindeutige Werte im Quellbereich (wozu?)
Set dt = CreateObject("Scripting.Dictionary")
For Each rng In InputRng
If rng.Value  "" Then dt(rng.Value) = ""
Next
'Ausgabe der eindeutigen Werte
OutRng.Resize(dt.Count, 1) = Application.WorksheetFunction.Transpose(dt.Keys)
'Bereich zu sortieren defineren
' Ein Bereich kann als Range(Range("A1"), Range("D4")) definiert werden
' aber auch als Range(Range("A4"), Range("D1")
With ActiveWorksheet.Sort
.SetRange Range(OutRng, ActiveSheet.Cells(Rows.Count, 1).End(xlUp))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'temporäre kopierte Daten wieder löschen
OutRng.Cells.ClearContents
Calculate
End Sub

VG
Yal

With ActiveWorksheet.Sort .SortFields.Clear .SortFields.Add Key:=Range(OutRng), SortOn:=xlSortOnValues, Order:=xlAscending .SetRange Range(OutRng, ActiveSheet.Cells(Rows.Count, 1).End(xlUp)) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With

Sub Eindeutige_Daten() With ActiveSheet.ListObjects(1) 'Remove Duplicate löscht die ganze Zeile, wenn in Spalte 1 ein Eintrag zum zweiten mal vorkommt .DataBodyRange.RemoveDuplicates Columns:=1, Header:=xlYes With .Sort .SortFields.Clear .SortFields.Add Key:=.Parent.DataBodyRange.Cells(1), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortTextAsNumbers .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With End Sub

Sub Eindeutige_Daten() Dim rng As Range Dim InputRng As Range Dim OutRng As Range Dim Spalte() As String Set InputRng = Application.InputBox("Range :", xTitleId, Selection.Address, Type:=8) Set OutRng = Application.InputBox("Output to (single cell):", xTitleId, Type:=8) Set OutRng = Intersect(InputRng.Rows(1).EntireRow, OutRng.Cells(1).EntireColumn) 'Aufnahme der eindeutige Werte im Quellbereich (wozu?) Set dt = CreateObject("Scripting.Dictionary") For Each rng In InputRng If rng.Value "" Then dt(rng.Value) = "" Next 'Ausgabe der eindeutigen Werte OutRng.Resize(dt.Count, 1) = Application.WorksheetFunction.Transpose(dt.Keys) 'Zellinhalt als Werte ActiveSheet.Range(OutRng, ActiveSheet.Cells(Rows.Count, 1).End(xlUp)).Value = ActiveSheet.Range(OutRng, ActiveSheet.Cells(Rows.Count, 1).End(xlUp)).Value 'Bereich zu sortieren defineren ' Ein Bereich kann als Range(Range("A1"), Range("D4")) definiert werden ' aber auch als Range(Range("A4"), Range("D1") With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=OutRng, SortOn:=xlSortOnValues, Order:=xlAscending .SetRange Range(OutRng, ActiveSheet.Cells(Rows.Count, 1).End(xlUp)) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'temporäre kopierte Daten wieder löschen OutRng.Cells.ClearContents Calculate End Sub

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Sortieren

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread