Zeilen Nummerierung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, i As Integer If Not Intersect(Target, Range("B20:IV500")) Is Nothing Then On Error GoTo ERRORHANDLER With Application .EnableEvents = False 'Ereignisse ausschalten .ScreenUpdating = False 'Bildschirmaktualisierung ausschalten .Cursor = xlWait 'Cursor "ruhigstellen" End With Range("A20:A500") = "" '"Alte" Nummereierung entfernen 'Alle Zellen des Bereiches durchlaufen For Each rng In Range("A20:A500") 'Nummerierung neu setzen If Application.CountA(Range(Cells(rng.Row, 2), Cells(rng.Row, 256))) > 0 Then i = i + 1 Cells(rng.Row, 1) = i End If Next End If ERRORHANDLER: 'Fehlerbehandlung With Application .EnableEvents = True 'Ereignisse einschalten .ScreenUpdating = True 'Bildschirmaktualisierung einschalten .Cursor = xlDefault End With End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, i As Integer If Not Intersect(Target, Range("B20:IV500")) Is Nothing Then On Error GoTo ERRORHANDLER With Application .EnableEvents = False 'Ereignisse ausschalten .ScreenUpdating = False 'Bildschirmaktualisierung ausschalten .Cursor = xlWait 'Cursor "ruhigstellen" End With Range("A20:A500") = "" '"Alte" Nummereierung entfernen 'Alle Zellen des Bereiches durchlaufen For Each rng In Range("A20:A500") 'Nummerierung neu setzen If Application.CountA(Range(Cells(rng.Row, 2), Cells(rng.Row, 256))) > 0 Then i = i + 1 Cells(rng.Row, 1) = i Rows(20).Copy Cells(rng.Row,1).Pastespecial xlPasteFormats End If Next End If ERRORHANDLER: 'Fehlerbehandlung With Application .EnableEvents = True 'Ereignisse einschalten .ScreenUpdating = True 'Bildschirmaktualisierung einschalten .Cursor = xlDefault End With End Sub

Hallo Erik!
Da würde ich persönlich lieiber auf eine Formel zurückgreifen!
Aber das musst du selber wissen!
Hier der Code setzt den Autofilter vor der Nummerierung zurück.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim i As Integer
If Not Intersect(Target, Range("B20:IV500")) Is Nothing Then
On Error GoTo ERRORHANDLER
With Application
.EnableEvents = False      'Ereignisse ausschalten
.ScreenUpdating = False    'Bildschirmaktualisierung ausschalten
.Cursor = xlWait           'Cursor "ruhigstellen"
End With
ActiveSheet.AutoFilterMode = False
Range("A20:A500") = ""  '"Alte" Nummereierung entfernen

   'Alle Zellen des Bereiches durchlaufen
   For Each rng In Range("A20:A500")
      'Nummerierung neu setzen
      If Application.CountA(Range(Cells(rng.Row, 2), Cells(rng.Row, 256))) > 0 Then
         i = i + 1
         Cells(rng.Row, 1) = i
         Rows(20).Copy
         Cells(rng.Row, 1).PasteSpecial xlPasteFormats
         Application.CutCopyMode = False
      End If

   Next
End If
ERRORHANDLER:  'Fehlerbehandlung

With Application
.EnableEvents = True     'Ereignisse einschalten
.ScreenUpdating = True   'Bildschirmaktualisierung einschalten
.Cursor = xlDefault
End With
End Sub

Gruß Sepp
P.S.: Rückmeldung nicht vergessen!

Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Tabelle1" Then Dim Loletzte As Long Dim LoI As Long Loletzte = 65536 If [a65536] = "" Then Loletzte = [a65536].End(xlUp).Row For LoI = Loletzte To 2 Step -1 If Cells(LoI, 11) <> Empty Then Exit For Next LoI ActiveSheet.PageSetup.PrintArea = "$A$1:$G$" & LoI End If End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread