AW: Blöcke nach Datum sortieren
04.03.2016 10:44:20
Daniel
Hi
probier mal folgendes.
die Verbundzellen darfst du behalten, da der Code nicht sortiert, sondern in der richtigen Reihenfolge kopiert.
Die Grösse und den Abstand der Karten muss konstant sein und du musst diese im Kopf des Makros angeben.
Sub BlockSort()
Const KarteSpalten As Long = 10
Const KarteZeilen As Long = 21
Const AbstandSpalten As Long = 11
Const AbstandZeilen As Long = 22
Const AnzahlSpalten As Long = 3
Const StartSpalte = 2
Const StartZeile = 2
Dim Blöcke As Range
Dim Zelle As Range
Dim shAkt As Worksheet
Dim shZW As Worksheet
Dim x As Long
Dim Zeile As Long
Dim Spalte As Long
Set shAkt = ActiveSheet
Set shZW = Sheets.Add(after:=shAkt)
With shAkt
.Cells.Replace "Kunde", True, xlWhole
Set Blöcke = .Cells.SpecialCells(xlCellTypeConstants, 4)
.Cells.Replace True, "Kunde"
End With
Zeile = 1
For Each Zelle In Blöcke
Zelle.Offset(-1, 0).Resize(KarteZeilen, KarteSpalten).Copy
shZW.Cells(Zeile, 3).PasteSpecial xlPasteAll
shZW.Cells(Zeile, 2).FormulaR1C1 = "=IF(R[3]C[3]="""",99999,R[3]C[3])+row()/10000"
shZW.Cells(Zeile, 1).FormulaR1C1 = "=RANK(RC2,C2,1)"
Zeile = Zeile + AbstandZeilen
Next
For x = 1 To WorksheetFunction.Max(shZW.Columns(1))
Zeile = StartZeile + Int((x - 1) / AnzahlSpalten) * AbstandZeilen
Spalte = StartSpalte + ((x - 1) Mod AnzahlSpalten) * AbstandSpalten
shZW.Columns(1).Find(what:=x, lookat:=xlWhole, LookIn:=xlValues).Offset(0, 2).Resize( _
KarteZeilen, KarteSpalten).Copy
shAkt.Cells(Zeile, Spalte).PasteSpecial xlPasteAll
Next
Application.DisplayAlerts = False
shZW.Delete
Application.DisplayAlerts = True
End Sub
getestet mit deiner Beispieldatei
gruß Daniel