AW: Datensortierung
07.05.2006 14:00:49
Reinhard
Hi Michael,
naja, die oberste völlig leere Zeile löschte ich weil sie nur unnötigen Aufwand für das
Makro hat. Bei meinem neuen Code kannste die restlichen Leerzeilen drinlassen,
sie werden automatisch nihct beachtet.
Tabelle1 ist das Ausgangstabellenblatt. Tabelle2 dient der Zwischensortierung.
In Tabelle3 wird die sortierte Liste von Tabelle1 erstellt.
Tabellenblattname: Tabelle1
A B
1 Der Teamleiter sollte ein ______ sein.
2 Visionär
3 Generalist
4
5 Welche Aussagen zu Projekten sind richtig?
6 Projekte sind einmalig.
7 Projekte benötigen und/oder verbrauchen Ressourcen.
8 Projekte erzeugen Veränderungen.
9 Projekte sind zeitlich begrenzt.
10 Projekte sind zielorientiert.
11 Projekte verursachen Kosten.
12
13 Die wichtigsten Phasen eines Projekts sind:
14 Realisierung
15 Nachbereitung
16 Konzept
17 Planung
18
19
20 Für den Dialog zur Dateneingabe wird empfohlen:
21 Der Gebrauch einer "Maske".
22 Der Gebrauch eines Dialogfelds.
Tabellenblattname: Tabelle3
A B
1 Der Teamleiter sollte ein ______ sein.
2 Generalist
3 Visionär
4 Die wichtigsten Phasen eines Projekts sind:
5 Konzept
6 Nachbereitung
7 Planung
8 Realisierung
9 Für den Dialog zur Dateneingabe wird empfohlen:
10 Der Gebrauch einer "Maske".
11 Der Gebrauch eines Dialogfelds.
12 Welche Aussagen zu Projekten sind richtig?
13 Projekte benötigen und/oder verbrauchen Ressourcen.
14 Projekte erzeugen Veränderungen.
15 Projekte sind einmalig.
16 Projekte sind zeitlich begrenzt.
17 Projekte sind zielorientiert.
18 Projekte verursachen Kosten.
19 Welche Informationsquellen gibt es im Internet, die...
20 FAQ (frequently asked questions)
21 Newsgroups
22 Suchmaschinen
Tabelle eingefügt mit Reinhards Tabelleneinfüger Version 1.0
Den neuen Code in ein Modul packen:
Option Explicit
Option Base 1
Sub sortieren()
Dim n As Long, zei2 As Long, zei1 As Long, anz1 As Long, Bereich(), zei3, nn
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
Set ws3 = Worksheets("Tabelle3")
With ws1
zei1 = 1
anz1 = anz1 + 1
ReDim Preserve Bereich(3, anz1)
Bereich(1, anz1) = .Cells(zei1, 1).Value
Bereich(2, 1) = zei1 'von
While zei1 <= .Range("A65536").End(xlUp).Row
zei1 = zei1 + 1
If .Cells(zei1, 1) <> "" Then
anz1 = anz1 + 1
ReDim Preserve Bereich(3, anz1)
Bereich(1, anz1) = .Cells(zei1, 1).Value
Bereich(2, anz1) = zei1 'von
Bereich(3, anz1 - 1) = zei1 - 1 'bis
End If
Wend
Bereich(3, anz1) = .Range("B65536").End(xlUp).Row
End With
With ws2
.UsedRange.ClearContents
For zei2 = 1 To anz1
.Cells(zei2, 1) = Bereich(1, zei2)
Next zei2
.UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
With ws3
.UsedRange.ClearContents
For n = 1 To anz1
For nn = 1 To anz1
If Bereich(1, nn) = ws2.Cells(n, 1) Then
zei3 = .Range("b65536").End(xlUp).Row
If zei3 <> 1 Then zei3 = zei3 + 1
ws1.Range(ws1.Cells(Bereich(2, nn), 1), ws1.Cells(Bereich(3, nn), 2)).Copy Destination:=.Cells(zei3, 1)
.Range(.Cells(zei3 + 1, 2), .Cells(.Range("b65536").End(xlUp).Row, 2)).Sort Key1:=.Cells(zei3 + 1, 2), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Exit For
End If
Next nn
Next n
End With
End Sub
Gruß
Reinhard
ps: Ich freue mich über eine Rückmeldung ob diese Antwort hilfreich war oder nicht..