Blöcke sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Larissa,
probier mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub BlockSort()
  Dim rng As Range, lngLast As Long

  On Error GoTo ErrExit
  GMS

  lngLast = Cells(Rows.Count, 1).End(xlUp) + 3

  Set rng = Range(Cells(2, 1), Cells(lngLast, 9))

  With rng
    .Columns(8).Formula = "=IF(ISBLANK(A2),H1,A2)"
    .Columns(9).Formula = "=IF(ISBLANK(B2),I1,B2)"
    .Sort Key1:=.Cells(1, 9), Order1:=xlAscending, _
      Key2:=.Cells(1, 8), Order2:=xlAscending, _
      Header:=xlNo
    .Columns(8).ClearContents
    .Columns(9).ClearContents
  End With



  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (BlockSort) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / BlockSort"
  End With

  GMS True
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)

  Static lngCalc As Long

  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)

  End With

End Sub

Gruß Sepp

Guten Morgen und hallo nochmal,
ich habe es geschafft, das Makro von Sepp an meine Tabelle anzupassen - *stolz ;-)
Leider ergeben sich nun zwei neue Fragen:
1. Nach dem Sortieren entsteht zwischen Zeile 877 und 39450 eine Lücke. Wahrscheinlich hat das Makro das Ende der Zeile nicht richtig erkannt, oder?
2. Spalte K bis R sind mit Formeln versehen. Nach der Sortierung werden nicht die richtigen Zellbezüge mitgenommen, so dass die falschen Werte bei den Namen stehen. Es ist wichtig, dass die Formeln stehenbleiben, weil man oben in Zeile 2 die Werte justieren können muss.
Ich lade noch mal die vollständige Tabelle mit meinem angepassten Makro von Sepp hoch...
https://www.herber.de/bbs/user/63564.xls
Ich würde mich schlappfreuen, wenn Ihr mir hier noch einmal weiterhelfen könnt :-)
Gruß Larissa

Sub Teste_Mal() Dim Bereich As Range Dim iCalc As Integer Set Bereich = Range("A1").End(xlDown) Set Bereich = Range(Bereich, Tabelle1.UsedRange.Find("*", , xlValues, 1, 1, 2, False, False, False).Offset(1, 0)) Set Bereich = Range(Bereich, Bereich.Columns(Bereich.Columns.Count).Offset(0, 2)) With Application iCalc = .Calculation .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual With Bereich.Columns(Bereich.Columns.Count - 1) .FormulaR1C1 = "=IF(RC4<>"""",RC4,R[-1]C)" .Offset(0, 1).FormulaR1C1 = "=ROW()" Bereich.Sort .Cells(1, 1), xlAscending, .Offset(0, 1).Cells(1, 1), , xlAscending, , , xlNo .Offset(0, 1).EntireColumn.Delete .EntireColumn.Delete End With .ScreenUpdating = True .EnableEvents = True .Calculation = iCalc End With End Sub

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread