AW: Sortieren-Makro funktioniert nicht
04.07.2016 11:52:32
mike49
Hallo Leute,
danke für die schnelle Hilfe.
UweD hat Recht. Einträge sind oder werden nur in den geraden Zeilen von Zeile A14 bis AA146 gemacht.
Wenn ich jetzt Einträge manuell rauslösche und durch neue ersetze, soll mit dem Makro das vorhandene Tabellenblatt neu sortiert werden. Es soll in kein neues Blatt kopiert werden. Ebenfalls sollen keine Eintrags-Leerzeilen zwischen den Einträgen stehen bleiben. Die Darstellung mit den ungeraden Einträgen ist so vorgegeben.
Leider bin ich makromäßig nicht so fit, um das selbst abzuändern bzw. neu aufzusetzen. Ich wäre dankbar, wenn jemand von euch helfen könnte. Das reine Sortieren Makro sieht so aus (hat jemand vor längerem hier im Forum für mich 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