Sortieren-Makro erweitern
30.07.2008 14:44:24
mike49
ich habe ein Sortieren-Makro, das auch funktioniert.
Ich wollte jetzt den Sortierbereich um 2 Zeilen erweitern und habe im Makro die Zahl 145 durch 147 ersetzt. Aber das funktioniert nicht, denn ein Eintrag in Zeile 147 wird nicht einfach einsortiert, sondern wieder gelöscht. Was habe ich falsch gemacht?
Sub Sortieren1()
'Variablendimensionierung
Dim i As Long, j As Long
Dim ws As Worksheet
'Variableninitialisierung
j = 1
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'Tabellenblatt wird hinzugefügt
Set ws = Worksheets.Add
ws.Visible = xlVeryHidden
'Kopieren der ungeraden Zellbereiche (Spalte A und D bis AD)
'zwischen Zeile 13 und Zeile 145 auf das neue Tabellenblatt
For i = 13 To 145
If i Mod 2 = 1 Then
With ActiveSheet
.Cells(i, "A").Copy _
Destination:=ws.Cells(j, "A")
.Range(.Cells(i, "C"), .Cells(i, "AA")).Copy _
Destination:=ws.Cells(j, "B")
j = j + 1
End With
End If
Next
With ws
'Nach doppelten Einträgen überprüfen und Inhalte löschen!
For i = 1 To 67
If Application.WorksheetFunction.CountIf(.Range("J18:J" & i), .Cells(i, "J")) > 1 Then
.Range("J" & i & ":Z" & i).ClearContents
End If
Next
'Spalten des neuen Tabellenblattes sortieren
.[A1:Z67].Sort Key1:=ws.[J1], Order1:=xlAscending, _
Key2:=ws.[I1], Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal
End With
'Bereiche auf dem aktiven Blatt löschen
With ActiveSheet
.[A13:A145].ClearContents
.[C13:AA145].ClearContents
End With
'Die Variable wird neu initialisiert!
j = 13
For i = 1 To 67
With ws
'Ist kein Liedtitel vorhanden, wird der Inhalt der ganzen Zeile gelöscht
If .Cells(i, "J") = "" Then
Range(.Cells(i, "A"), .Cells(i, "AA")).ClearContents
End If
'Zeilen vom hinzugefügten Tabellenblatt wieder zurückkopieren
.Cells(i, "A").Copy _
Destination:=ActiveSheet.Cells(j, "A")
.Range("B" & i & ":" & "AB" & i).Copy _
Destination:=ActiveSheet.Cells(j, "C")
j = j + 2
End With
Next
'Fehlermeldung ausschalten
Application.DisplayAlerts = False
'Hinzugefügtes Tabellenblatt wird wieder sichtbar und dann gelöscht
With ws
.Visible = True
.Delete
End With
[A1].Select
'Fehlermeldung wieder einschalten
Application.DisplayAlerts = True
End Sub
Gruß mike49