DVD-Liste automatisch sortieren lassen

Sub LfdNrVergeben()

 Const c_BLATTNAME = Tabelle2
 Const c_TAB_NAME = Tabelle1
 Const c_TAB_RANGE_NR = Tabelle1[[#All],[Nr.]]
 Const c_TAB_RANGE_FILM = Tabelle1[[#All],[Film]]
 Const c_SP_NR = 1->SpaltenNr für Nr.
 Const c_SP_FILM = 2->SpaltenNr für Film
 
 Dim ws As Worksheet, tb As Object
 Dim zLetzte_Nr As Long, zLetzte_Film As Long, z_tb_letzte As Long, z_tb_header As Long
 Dim lfdNr As Long, z As Long, zStart As Long
 Dim bErr As Boolean
 
->Blatt setzen
 Set ws = ThisWorkbook.Worksheets(c_BLATTNAME)
->Tabelle setzen
 Set tb = ws.ListObjects(c_TAB_NAME)
->Alle Tab-Filter zurücksetzen
 tb.Sort.SortFields.Clear
 
->letzte Tabellenzeile feststellen
 z_tb_letzte = tb.Range.Row + tb.ListRows.Count
->HeaderzeileNr feststellen
 z_tb_header = tb.HeaderRowRange.Row
 
->Tabelle nach Nummer sortieren, sekundär nach Film sortieren, damit ggf Leerzeilen nach unten verschoben werden
 With tb.Sort
  .SortFields.Clear
  .SortFields.Add _
    Key:=Range(c_TAB_RANGE_NR), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
  .SortFields.Add _
    Key:=Range(c_TAB_RANGE_FILM), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .Apply
 End With
  
->letzte Zeile in Spalte Film feststellen
 If ws.Cells(z_tb_letzte, c_SP_FILM) <>  Then
  zLetzte_Film = z_tb_letzte
 Else
  zLetzte_Film = ws.Cells(z_tb_letzte, c_SP_FILM).End(xlUp).Row
 End If
->prüfen, ob keine Daten in Spalte Film vorhandnen sind. Ggf. Abbruch
 If z_tb_header >= zLetzte_Film Then MsgBox (Spalte -Film- enhält keine Daten): GoTo AUFRAEUMEN
 
->letzte Zeile in Spalte Nr. feststellen
 If ws.Cells(z_tb_letzte, c_SP_NR).Value <>  Then
  zLetzte_Nr = z_tb_letzte
 Else
  zLetzte_Nr = ws.Cells(z_tb_letzte, c_SP_NR).End(xlUp).Row
 End If
 
->Wenn alle Zeilen in Spalte Film bereits eine Nummer besitzen -> Abbrechen
 If zLetzte_Nr < zLetzte_Film Then
 ->letzte verwendete laufend Nummer feststellen. Bei Fehler erfolgt Meldung und Abbruch.
  If z_tb_header >= zLetzte_Nr Then
   lfdNr = 0
  Else
   On Error Resume Next
   lfdNr = ws.Cells(zLetzte_Nr, c_SP_NR).Value
   If Err.Number <> 0 Then bErr = True
   On Error GoTo 0
   If bErr Then
    ws.Cells(zLetzte_Nr, c_SP_NR).Select
    MsgBox (Fehler: letzte laufende Nr. kann nicht gelesen werden)
    GoTo AUFRAEUMEN
   End If
  End If
  
 ->laufend Nummern eintragen
  zStart = zLetzte_Nr + 1
  For z = zStart To zLetzte_Film
   zLetzte_Nr = zLetzte_Nr + 1
   lfdNr = lfdNr + 1
   ws.Cells(zLetzte_Nr, c_SP_NR).Value = lfdNr
  Next
  
 ->Tabelle nach Film sortieren
  With tb.Sort
   .SortFields.Clear
   .SortFields.Add _
     Key:=Range(c_TAB_RANGE_FILM), _
     SortOn:=xlSortOnValues, _
     Order:=xlAscending, _
     DataOption:=xlSortNormal
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .Apply
  End With
 
 ->letze eingetragene laufende Nummer selektieren
  If ((z_tb_header + 1) <> zLetzte_Nr) Then
   ws.Range(ws.Cells(z_tb_header + 1, c_SP_NR), _
        ws.Cells(zLetzte_Nr, c_SP_NR)).Find(What:=lfdNr, LookAt:=xlWhole).Activate
  Else
   ws.Cells(zLetzte_Nr, c_SP_NR).Select
  End If
 Else
 ->Tabelle nach Film sortieren
  With tb.Sort
   .SortFields.Clear
   .SortFields.Add _
     Key:=Range(c_TAB_RANGE_FILM), _
     SortOn:=xlSortOnValues, _
     Order:=xlAscending, _
     DataOption:=xlSortNormal
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .Apply
  End With
 End If
 
 
AUFRAEUMEN:
 Set ws = Nothing: Set tb = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

 Dim objRange As Range
 Set objRange = Intersect(Target, Range(B:B))->Bereich anpassen
 If Not objRange Is Nothing Then
  Call LfdNrVergeben
 End If
 Set objRange = Nothing
End Sub

Function LfdNrVergeben2(z_ersteAenderungsZeile As Long)

 Const c_BLATTNAME = Tabelle2
 Const c_TAB_NAME = Tabelle1
 Const c_TAB_RANGE_FILM = Tabelle1[[#All],[Film]]
 Const c_TAB_RANGE_NR = Tabelle1[Nr.]
 Const c_SP_NR = 1->SpaltenNr für Nr.
 Const c_SP_FILM = 2->SpaltenNr für Film
 
 Dim ws As Worksheet, tb As Object
 Dim zLetzte_Film As Long, z_tb_letzte As Long, z_tb_header As Long
 Dim z As Long, zStart As Long
 Dim sFilmName As String
 
->Blatt setzen
 Set ws = ThisWorkbook.Worksheets(c_BLATTNAME)
->Tabelle setzen
 Set tb = ws.ListObjects(c_TAB_NAME)
 
->editieren Filmnamen retten
 sFilmName = ws.Cells(z_ersteAenderungsZeile, c_SP_FILM).Value
 
->Alle Tab-Filter zurücksetzen
 tb.Sort.SortFields.Clear
 
->letzte Tabellenzeile feststellen
 z_tb_letzte = tb.Range.Row + tb.ListRows.Count
->HeaderzeileNr feststellen
 z_tb_header = tb.HeaderRowRange.Row
 
->Tabelle nach Film sortieren
 With tb.Sort
  .SortFields.Clear
  .SortFields.Add _
    Key:=Range(c_TAB_RANGE_FILM), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .Apply
 End With
  
->letzte Zeile in Spalte Film feststellen
 If ws.Cells(z_tb_letzte, c_SP_FILM) <>  Then
  zLetzte_Film = z_tb_letzte
 Else
  zLetzte_Film = ws.Cells(z_tb_letzte, c_SP_FILM).End(xlUp).Row
 End If
 
->prüfen, ob keine Daten in Spalte Film vorhandnen sind. Ggf. Abbruch
 If z_tb_header >= zLetzte_Film Then MsgBox (Spalte -Film- enhält keine Daten): GoTo AUFRAEUMEN
 
->erste laufend Nummern eintragen
 ws.Cells(z_tb_header + 1, c_SP_NR).Value = 1
 
 If z_tb_header + 1 < zLetzte_Film Then
 ->Splate Nr. fortlaufend nummerieren
  ws.Cells(z_tb_header + 1, c_SP_NR).AutoFill Destination:=Range(c_TAB_RANGE_NR), Type:=xlFillSeries
 
 ->letzten geänderten Filmnamen selektieren
   ws.Range(ws.Cells(z_tb_header + 1, c_SP_FILM), _
        ws.Cells(zLetzte_Film, c_SP_FILM)).Find(What:=sFilmName, LookAt:=xlWhole).Activate
 End If
 
AUFRAEUMEN:
 Set ws = Nothing: Set tb = Nothing
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim objRange As Range
 Set objRange = Intersect(Target, Range(B:B))->Bereich anpassen
 If Not objRange Is Nothing Then Call LfdNrVergeben2(objRange.Row)
 Set objRange = Nothing
End Sub