VBA - Liste sortieren mit definierter Lücke

[EasY]

Hi Leute,

ich tüftel gerade an einem neuen Problem und frage mich, ob das so überhaupt mit VBA lösbar ist....

Ich habe eine Liste in einem fest definierten Bereich (schwarzer Rahmen). Diese soll sortiert werden und anschließend sollen einige der Einträge ans Listenende gesetzt werden. Das Problem dabei ist, dass die Urpsrungsliste sich ändern kann, also auch die Anzahl der Einträge und damit auch die Anzahl der Leerzellen.

Ich habe versucht, das Problem in folgendem Beispiel darzustellen. Das Sortieren funktioniert soweit gut. Im Prinzip müsste nach dem Sortieren ein Verschieben-Makro laufen, welches die untersten Einträge, die nicht "x" und nicht "xS" sind nach unten setzt.



Ist das möglich?

[Gast 123]

Hallo

mit dem unteren Makro sollte es gehen. Ein Tipp, ich sortiere mit Descending = Abwaerts sortieren von Z nach A, dann kommen die Daten vor x + xS ohnehin nach unten zu stehen. Sie finden und verschieben macht die For Next Schleife.  In der Const Anweisung steht Endzell.  Der Wert gibt an ab welcher Zeile die Daten verschoben werden. Der Wert kann von Hand beliebig erhöht werden. Die Sortierroutine passt sich den Zeilen automatisch an, wenn keine Lerrzeilen dazwischen sind! Bitte daran denken das die Endzeile zum verschieben grösser sein muss, sonst überschreibt man Daten!

mfg  Gast 123

Code:

Option Explicit

Const EndZell = 20


Sub Makro1()
Dim leer, j, lzA As Long   'LastZell in Spalte A
With ActiveWorkbook.Worksheets("Tabelle1")
    lzA = .Cells(1, 1).End(xlDown).Row
   .Sort.SortFields.Clear
   .Sort.SortFields.Add Key:=Range("B2"), SortOn:=xlSortOnValues, _
     Order:=xlDescending, DataOption:=xlSortNormal
   With .Sort
       .SetRange Range("A2:B" & lzA)
       .Header = xlGuess
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With

  leer = EndZell   '1. Leerzeile unter Sortierung
 
  For j = 2 To lzA
     If .Cells(j, 2) = "x" Or .Cells(j, 2) = "xS" Then
     Else
        .Cells(j, 1).Resize(1, 2).Copy .Cells(leer, 1)
        .Cells(j, 1).Resize(1, 2).Value = Empty
         leer = leer + 1
     End If
  Next j
End With
End Sub

[EasY]

Sehr sehr geil... .DANKE!

Wenn ich den Bereich, in dem die Daten liegen, die sortiert werden sollen noch besser eingrenzen möchte, muss ich die Variable "lza" genauer bestimmen, oder?

In der späteren Datei liegen bspw in A1:B15 Daten, die sortiert werden sollen, in A25:B40 dann auch noch mal ... etc


Mir kommt gerade eine Idee... der Button, mit dem ich eine Sortierung durchführen werde, liegt immer im gleichen Bereich der zur sortierenden Daten (oben links davon) ... dann muss ich nicht 15 Makros für 15 Bereiche kopieren, sondern kann mir die "lza" abhängig von der eigenen Position, in der der Button liegt, bestimmen. Habe sowas schonmal programmiert, muss es allerdings eben raussuchen ... oder wird das nix?

Gruß

P.S.: ThisWorkbook.Sheets("Tabelle1").Shapes(Application.Caller).TopLeftCell.Row müsste die Stelle sein... richtig?

[Gast 123]

Hallo

ja, gute Idee um die Zelle Oben Links zu ermitteln.  Geht auch so:  FirsrZell = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row

mfg  Gast 123

[EasY]

Hi,

ich benötige noch einmal Hilfe

Code:

Sub Sortieren()
Dim leer, j, lzA As Long   'LastZell in Spalte A
With ThisWorkbook.Sheets("ESD")
   lzA = .Cells(24, 2).Row
  .Sort.SortFields.Clear
  .Sort.SortFields.Add Key:=Range("B6"), SortOn:=xlSortOnValues, _
    Order:=xlDescending, DataOption:=xlSortNormal
  With .Sort
      .SetRange Range("B6:C" & lzA)
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With

 leer = EndZell   '1. Leerzeile unter Sortierung

 For j = 6 To lzA
    If .Cells(j, 3) = "X" Or .Cells(j, 3) = "Xn" Then
    Else
       .Cells(j, 2).Resize(1, 2).Copy .Cells(leer, 2)
       .Cells(j, 2).Resize(1, 2).Value = Empty
        leer = leer + 1
    End If
 Next j
End With
End Sub

Ich habe den Code nun angepasst, er funktioniert jedoch in der Original-Mappe nicht so, wie er soll. Im Bereich B6:C24 liegen die zu sortierenden Daten. In C6:C24 sind die Begriffe, die er zunächst sortieren soll.

1. Problem:
Wenn ich den Code mit F8 durchlaufen lasse, schreibt er Daten zwei Mal nach unten und vor allem auch außerhalb des Bereichs B6:C24.

2. Problem:
Es ist weniger ein Problem, als ein Addon ... Ich habe vergeblich versucht, eine Sortierliste mit Application.AddCustomList einzufügen. Der Begriff "DA" in C6:C24 soll oben stehen, danach "EW", dann "X" und dann "T" ... der Rest ("U", "A" etc.) soll dann nach unten an das Ende geschrieben werden. Ist das möglich?


Gruß

[Gast 123]

Hallo

Application.AddCustomList einzufügen

mit dieser Liste habe ich noch nie gearbeitet, habe leider keine Ahnung was sie macht, oder wie sie funktioniert???
Behelfsweise machte ich mir eine Hilfsspalte daneben, legte für die gültigen Daten ein "X" oder "A,B,C" rein, und sortierte zuerst nach der Hilfsspalte. Dann stehen die gewünschten Daten auch oben. Ist aber der Behelf eines Laien.  Funktionierte trotzdem ...

Kannst du bitte eine Beispieldatei mit Fantasie Daten, aber wie im Original hochladen. Dann schaue ich mir den Code an. Normalerweise sollte dein Code laufen! Wenn Nicht ....????   Hier kannst du auch gleich  lzA = 24 eingeben, ohne Cells().Row! lzA = .Cells(24, 2).Row

mfg  Gast 123

[EasY]

Hier die Datei :)

[Gast 123]

Hallo

mit dieser Makro Mischung aus sortieren, nach unten Stellen, ans Ende verschieben sollte es gehen.  Vielleicht etwas umstaendlich, funktioniert aber!

mfg  Gast 123

Code:

Option Explicit

Const EndZell = 18


Sub Sortieren_verschieben()
Dim leer, j, lzA As Long   'LastZell in Spalte A
With ThisWorkbook.Sheets("Tabelle1")
   lzA = .Cells(6, 2).End(xlDown).Row
   If lzA > 24 Then Exit Sub  'Tab. leer
 
  leer = EndZell
  'alle ungültigen Werte vor Sortieren verschieben
  For j = 6 To lzA
     If .Cells(j, 3) = "DA" Or .Cells(j, 3) = "EW" Or _
        .Cells(j, 3) = "X" Or .Cells(j, 3) = "T" Then
     Else  'ungültige Werte ans Ende verschieben
       .Cells(j, 2).Resize(1, 2).Copy .Cells(leer, 2)
       .Cells(j, 2).Resize(1, 2).Value = Empty
        leer = leer + 1
     End If
  Next j

  'Bereich sortieren, alles ausser "T" wird richtig sortiert
  .Sort.SortFields.Clear
  .Sort.SortFields.Add Key:=Range("C6"), SortOn:=xlSortOnValues, _
    Order:=xlAscending, DataOption:=xlSortNormal
  With .Sort
      .SetRange Range("B6:C" & lzA)
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With

  'lzA nach sortieren neu ermitteln
  lzA = .Cells(6, 2).End(xlDown).Row
  leer = lzA + 1

  'Buchstabe "T" per For Next verschieben
  For j = lzA To 6 Step -1
     If .Cells(j, 3) = "T" Then
        'Wert nach unten verschieben
        .Cells(j, 2).Resize(1, 2).Copy .Cells(leer, 2)
        'ganzen Block mit Leerzeile noch oben kopieren
        .Cells(j + 1, 2).Resize(lzA - j + 2, 2).Copy
        .Cells(j, 2).PasteSpecial xlPasteValues
     End If
  Next j
  Application.CutCopyMode = False
  Range("B6").Select
End With
End Sub

[EasY]

Hey Gast123,

leider klappt es nicht ganz so wie ich mir das vorstelle ... wenn die Liste sehr voll ist, schreibt er immer über den Bereich hinaus und manchmal werden nicht alle Einträge nach unten geschoben sondern fallen einfach weg

[EasY]

Und wenn man den Bereich zunächst in ein anderes Tabellenblatt kopiert, dort dann sortiert (da hat man ja mehr Platz) und dann wieder in der richtigen Reihenfolge zurückkopiert - samt Leerzellen, wenn genug Platz ist?

Ich weiß, das ist schnell mal dahergesagt, aber vll kann man das mit VBA ja umsetzen :).



P.S.: Ich habe mich ran gemacht und freue mich gerade riesig, dass es auf Anhieb geklappt hat (Case "T" fehlt noch). Vielleicht kann das noch wer einkürzen bzw überprüfen, ob irgendwo Klinken drin sind. Habe es mit dem Makro-Rekorder teilweise gemacht und ich weiß, dass der nicht immer alle Eventualitäten beachtet. Irgendwas noch löschen, was sonst dauerhaft gespeichert wird oder Ähnliches?

Code:

Sub Makro1()

Dim i As Integer

   With ThisWorkbook.Sheets("Tabelle1")
       .Range("B6:C24").Copy _
       Destination:=.Range("I6")
   End With
   
   For i = 6 To 24
       With ThisWorkbook.Sheets("Tabelle1")
           Select Case .Cells(i, 10)
               Case "DA"
                   .Cells(i, 11).Value = 1
               Case "EW"
                   .Cells(i, 11).Value = 2
               Case "X", "x"
                   .Cells(i, 11).Value = 3
               Case ""
                   .Cells(i, 11).Value = 4
               Case Else
                   .Cells(i, 11).Value = 5
           End Select
       End With
   Next i

   ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
   ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add2 Key:=Range( _
       "K6:K24"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
       xlSortNormal
   With ActiveWorkbook.Worksheets("Tabelle1").Sort
       .SetRange Range("I6:K24")
       .Header = xlGuess
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
   
   With ThisWorkbook.Sheets("Tabelle1")
       .Range("I6:J24").Copy _
       Destination:=.Range("B6")
   End With
End Sub