Live-Forum - Die aktuellen Beiträge
Datum
Titel
24.04.2024 19:29:30
24.04.2024 18:49:56
24.04.2024 17:19:09
Anzeige
Archiv - Navigation
1032to1036
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Fortlaufende Nummerierung in Spalte per VBA
15.12.2008 00:08:14
Lenhard
Moin Excellianer!
Ich bin gerade in den "Weiten des Archivs" unterwegs gewesen. Zum Thema "Fortlaufende Nummerierung in einer Spalte per VBA" findet man im Archiv unglaublich viel... ...aber für meine Frage nicht die passende Antwort.
Wenn in der Spalte C eines Tabellenblattes ab der Zeile 16 ein Eintrag gemacht wird, dann soll in der Spalte B ab der Zeile 16 eine fortlaufende Nummerierung mit dem Format 0001 beginnen.
Wenn aber zum Beispiel später einzelne Einträge in der Spalte C entfernt werden, so soll die fortlaufende Nummerierung in der Spalte B nach oben aufschließen. Und genau zu diesem Problem finde ich keine Antworten...
Mit Formeln direkt in der Spalte B ist das für mich kein Problem, steht aber weiteren Funktionen in meiner Datei extrem im Wege!! Deshalb würde ich mich über eine VBA-Lösung sehr freuen, so dass die fortlaufende Nummerierung als Zahlenwert (...könnte aber auch Textwert sein) dort steht.
Vielen Dank für Eure Hilfe!
Viele Grüße aus dem hohen Norden
Lenni

30
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Fortlaufende Nummerierung in Spalte per VBA
15.12.2008 00:37:00
Tino
Hallo,
kommst Du hiermit zurecht?
Kommt als Code ins entsprechende Tabellenblatt.
Microsoft Excel Objekt Tabelle1
Option Explicit 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
Dim Bereich As Range 
Dim meArea 
Dim i As Long, A As Long 
 
If Intersect(Target, Range("A16", Cells(Rows.Count, 1))) Is Nothing Then Exit Sub 
  
Application.EnableEvents = False 
     
    Set Bereich = Range("A16", Cells(Rows.Count, 1).End(xlUp)) 
   
  If Bereich.Cells.Count = 1 Then 
     Bereich.Offset(0, 1) = "'" & Format(1, "0000") 
  Else 
        meArea = Bereich 
        For A = 1 To Ubound(meArea, 1) 
         If meArea(A, 1) <> "" Then: i = i + 1: meArea(A, 1) = "'" & Format(i, "00000") 
        Next A 
        Bereich.Offset(0, 1) = meArea 
  End If 
Application.EnableEvents = True 
 
End Sub 


Gruß Tino

Anzeige
Falsche Spalte, Korrektur
15.12.2008 00:39:49
Tino
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim meArea
Dim i As Long, A As Long

If Intersect(Target, Range("C16", Cells(Rows.Count, 3))) Is Nothing Then Exit Sub
 
Application.EnableEvents = False
    
    Set Bereich = Range("C16", Cells(Rows.Count, 3).End(xlUp))
  
  If Bereich.Cells.Count = 1 Then
     Bereich.Offset(0, -1) = "'" & Format(1, "0000")
  Else
        meArea = Bereich
        For A = 1 To Ubound(meArea, 1)
         If meArea(A, 1) <> "" Then: i = i + 1: meArea(A, 1) = "'" & Format(i, "00000")
        Next A
        Bereich.Offset(0, -1) = meArea
  End If
Application.EnableEvents = True

End Sub


Anzeige
Nochmal
15.12.2008 00:55:51
Tino
Hallo,
ich mach jetzt Feierabend, zu lange am PC.
Spalte B muss zuvor auch gelöscht werden.
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim meArea
Dim i As Long, A As Long

If Intersect(Target, Range("C16", Cells(Rows.Count, 3))) Is Nothing Then Exit Sub
 
Application.EnableEvents = False
  
  Range("B16", Cells(Rows.Count, 2)).ClearContents
    
  Set Bereich = Range("C16", Cells(Rows.Count, 3).End(xlUp))
  
  If Bereich.Cells.Count = 1 Then
     Bereich.Offset(0, -1) = "'" & Format(1, "0000")
  Else
        meArea = Bereich
        For A = 1 To Ubound(meArea, 1)
         If meArea(A, 1) <> "" Then: i = i + 1: meArea(A, 1) = "'" & Format(i, "0000")
        Next A
        Bereich.Offset(0, -1) = meArea
  End If
Application.EnableEvents = True

End Sub


Gute Nacht
Gruß Tino

Anzeige
AW: Nochmal
15.12.2008 01:00:00
Lenhard
Danke Tino! ...das funktioniert bis auf eine Kleinigkeit: Die fortlaufende Nummerierung schließt nicht nach oben auf, wenn in der Spalte C ein Eintrag entfernt wird.
Danke nochmals!
Gruß
Lenni
AW: Nochmal
15.12.2008 09:25:00
Tino
Hallo und Guten Morgen,
mit diesem Code funktioniert es.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim meArea
Dim i As Long, A As Long

If Intersect(Target, Range("C16", Cells(Rows.Count, 3))) Is Nothing Then Exit Sub
With Application
 .EnableEvents = False
 .ScreenUpdating = False
  
  Range("B16", Cells(Rows.Count, 2)).ClearContents
If Cells(Rows.Count, 3).Row <> Range("C15").End(xlDown).Row Then
  Set Bereich = Range("C16", Cells(Rows.Count, 3).End(xlUp))
  
  If Bereich.Cells.Count = 1 Then
     Bereich.Offset(0, -1) = "'" & Format(1, "0000")
  Else
        meArea = Bereich
        For A = 1 To Ubound(meArea, 1)
         If meArea(A, 1) <> "" Then: i = i + 1: meArea(A, 1) = "'" & Format(i, "0000")
        Next A
        Bereich.Offset(0, -1) = meArea
  End If
End If
 .EnableEvents = True
 .ScreenUpdating = True
End With

End Sub


Oder meist Du die leeren Zellen sollen komplett gelöscht werden?
Gruß Tino

Anzeige
AW: Nochmal
15.12.2008 10:44:00
Lenhard
Guten Morgen Tino! Zu aller Erst: Vielen Dank!!
Der Code funktioniert auch sehr gut!! ...aber mein Problem ist in der Tat so: Wenn eine Zelle in der Spalte C leer ist, dann sollte oder müßte die fortlaufende Nummerierung in der Spalte B nach oben aufschließen. Also Lücken müßten geschlossen werden.
Danke nochmals Tino!!
Gruß
Lenni
AW: Nochmal
15.12.2008 11:07:47
Tino
Hallo,
versuche es mal hiermit.
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim meArea, tempArea
Dim i As Long, A As Long

If Intersect(Target, Range("C16", Cells(Rows.Count, 3))) Is Nothing Then Exit Sub
With Application
 .EnableEvents = False
 .ScreenUpdating = False
  
Range("B16", Cells(Rows.Count, 2)).ClearContents
If Cells(Rows.Count, 3).Row <> Range("C15").End(xlDown).Row Then
  
  Set Bereich = Range("B16", Range("C16", Cells(Rows.Count, 3).End(xlUp)))
  
  meArea = Bereich
  Bereich.ClearContents
  tempArea = Bereich

        For A = 1 To Ubound(meArea, 1)
         If meArea(A, 2) <> "" Then
          i = i + 1
          tempArea(i, 1) = "'" & Format(i, "0000")
          tempArea(i, 2) = meArea(A, 2)
         End If
        Next A
   Bereich = tempArea

End If
 .EnableEvents = True
 .ScreenUpdating = True
End With

End Sub


Gruß Tino

Anzeige
AW: Nochmal
15.12.2008 11:40:00
Lenhard
Super Tino!! Das ist genau das, was mir entscheidend weiter hilft!!!
Nun sag ich: Vielen vielen Dank!!
Gruß
Lenni
AW: Nochmal
15.12.2008 16:36:35
Lenhard
Hallo Tino! ...ich muss mich doch noch mal melden!!
Weil: Du hast das "Aufschließen nach oben" allzu wörtlich genommen und es auf beide Spalten bezogen. Ich meinte aber immer nur Spalte B.
Es soll aber nur die fortlaufende Nummerierung in der Spalte B nach oben aufschließen, weil in der Spalte C automatisch nach einer Sortierungsprozedur nach oben aufgeschlossen wird, wenn denn dort gelöscht wird.
Das muss auch leider so bleiben, da ich mit UserForms Daten ab Spalte C (...bis N) eintrage, suche, änder oder auch lösche.
Oder - die Idee kommt mir gerade hier beim schreiben - könnte man den Bereich nicht einfach von Spalte C bis Spalte N ausdehnen...
Ich schau mal. Da ich aber nicht der VBA-Crack bin, wäre es trotzdem nett, wenn Du auch noch mal schauen könntest.
Danke nochmals!!
Gruß
Lenni
Anzeige
?
15.12.2008 16:50:45
Tino
Hallo,
was wie jetzt, ich kann jetzt nicht folgen, nach oben aufschließen, nicht dazwischen löschen?
Bau mal eine Beispieldatei auf, mit vorher und nachher.
Gruß Tino
AW: ?
15.12.2008 17:32:00
Lenhard
Danke für die Rückmeldung, Tino! ...ja das dachte ich mir schon, das man meinen Gedanken nun nicht mehr so richtig folgen kann.
Ich schau mal mit der Beispieldatei, die Datei, die ich hier habe ist schon zu groß zum übertragen... ...das kann nur ein wenig dauern (...ich muss ja zwischendurch immer zur Arbeit).
Sollte dieser Beitrag bis dahin ins Archiv rutschen, mache ich einen neuen Theard auf! Erst mal vielen Dank Tino!!
Gruß
Lenni
Anzeige
AW: ?
15.12.2008 19:18:06
Lenhard
Hallo Tino! ...darf ich Dich noch mal nerven?!
Kann man den Bereich der Spalte C ab Zeile 16 bis zu den Bereich der Spalte N Zeile 16 erweitern?!? Ich glaube, dann ist mein Problem gelöst ...ich schaffe es nicht, Deinen Code zu erweitern. Ich habe wohl noch zu wenig VBA-Ahnung...
Danke!
Gruß
Lenni
vieleicht so
15.12.2008 20:13:19
Tino
Hallo,
für solch einen Großen Zellbereich, fällt mir nur diese Variante ein.
Microsoft Excel Objekt Tabelle1
Option Explicit 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
Dim Bereich As Range 
Dim meArea 
Dim i As Long, A As Long 
Set Bereich = Range("C16:N" & UsedRange(UsedRange.Cells.Count).Row) 
 
If Intersect(Target, Bereich) Is Nothing Then Exit Sub 
 
With Application 
 .EnableEvents = False 
 .ScreenUpdating = False 
   
Range("B16", Cells(Rows.Count, 2)).ClearContents 
 
If Cells(Rows.Count, 3).Row <> Range("C15").End(xlDown).Row Then 
   
Set Bereich = Range("B16:B" & UsedRange(UsedRange.Cells.Count).Row) 
  Bereich.FormulaR1C1 = "=COUNTA(RC3:RC14)" 
  meArea = Bereich 
  Bereich.ClearContents 
 
 
        For A = 1 To Ubound(meArea, 1) 
         If meArea(A, 1) > 0 Then 
          i = i + 1 
          meArea(A, 1) = "'" & Format(i, "0000") 
         Else 
          meArea(A, 1) = "=True" 
         End If 
        Next A 
    
   Bereich = meArea 
   Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete 
End If 
 .EnableEvents = True 
 .ScreenUpdating = True 
End With 
 
End Sub 
 


Gruß Tino

Anzeige
AW: vieleicht so
15.12.2008 20:58:00
Lenhard
Danke Tino! ...das Du Dich noch mal gemeldet hast! Aber leider wird mir
Laufzeitfehler 13, Typen unverträglich ...und die Zeile "Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete" wird gelb unterlegt
Weiter wird Laufzeitfehler 1004, Keine Zellen gefunden angezeigt
Gruß
Lenni
keine leerer Bereich zwichen C und N...
15.12.2008 21:25:00
Tino
Hallo,
ersetzte die Zeile
Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
durch diese
If Application.WorksheetFunction.CountIf(Bereich, True) > 0 Then
Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
End If


Gruß Tino

Anzeige
AW: keine leerer Bereich zwichen C und N...
15.12.2008 22:15:00
Lenhard
Hallo Tino!
Habe ich gemacht! ...aber nun bekomme ich andere Fehlermeldungen.
Tino, ich habe mir mal erlaubt eine kleine Beispielmappe mit einem von Dir bereits vorgestellten Code zu erstellen und ich habe das Problem noch mal dort hinein geschrieben. Vielleicht hilft das weiter!
https://www.herber.de/bbs/user/57644.xls
Danke nochmals Tino!! Ich finde es Super, mit welcher "Engelsgeduld" Du mir hilfst!!
Gruß
Lenni
AW: keine leerer Bereich zwichen C und N...
15.12.2008 22:37:50
Tino
Hallo,
hier Deine Beispieldatei, bei mir funktioniert es (keine Fehler), muss aber dazu sagen ich habe xl2003.
https://www.herber.de/bbs/user/57645.xls
Solltest Du Fehler bekommen, sag mir bitte welchen Fehler Du bekommst und in welcher Zeile.
Gruß Tino
AW: keine leerer Bereich zwichen C und N...
15.12.2008 22:44:26
Lenhard
Hallo Tino!
Ich habe probeweise den Eintrag in der Zelle C19 gelöscht, da wird mir in der Zelle B19 "#NAME?" angezeigt und in der Bearbeitungsleiste steht als Formel "=True" für diese Zelle...
Danke Tino!
Gruß
Lenni
AW: keine leerer Bereich zwichen C und N...
15.12.2008 23:10:00
Lenhard
Danke nochmals Tino!
Aber leider die gleiche Fehlermeldung: Es wird "#NAME?" angezeigt und in der Bearbeitungsleiste steht als Formel "=True" für die Zelle in Spalte B neben der soeben gelöschten Zelle in der Spalte C...
Aber lass Dir Zeit!! ...ich muss nun sowieso ins Bett. Ich muss morgen sehr früh raus, zur Arbeit, habe am Nachmittag Termine und komme erst am Abend wieder an den Rechner....
Danke Tino!!!
Gruß
Lenni
AW: muss doch funktionieren!
16.12.2008 09:37:12
Tino
Hallo,
habe einen Rechner mit Office XP gefunden.
Diese Version funktioniert auf alle fälle.
https://www.herber.de/bbs/user/57657.xls
Gruß Tino
PS: wünsche noch frohe Weihnachten und einen guten Rutsch
AW: muss doch funktionieren!
16.12.2008 15:39:34
Lenhard
Moin Tino!!
Ganz ganz herzlichen Dank!!! ...nach einem vorläufigen Test läuft es!! Ich bin kurz zu Hause und konnte es mir kurz ansehen.
UND: Danke, dass Du Dir die Mühe machst, extra einen Rechner mit Excel XP zu suchen!!
Ich komme erst heute Abend zum ausführlichen Testen. Aber bis dahin noch eine Frage (...falls Du zufällig am Rechner sitzen solltest): Im Modul finde ich ein "Makro3". Hat das irgend eine wichtige Relevanz?! ...jedenfalls sehe (...oder übersehe?!) ich den Aufruf an das Makro3 in Deinem Skript nicht?!
Und mir ist da noch etwas aufgefallen: Das kleine Apostroph vor der den Zahlen der fortlaufenden Nummerierung. Darf ich Dich bitten, mir das zu erklären. Es reicht eine kurze Erklärung (...ich sehe ja, dass Du sehr viel im Forum "unterwegs" bist).
Ich schaue heute Abend - nach einer ausführlichen Testung - noch mal ins Forum.
Vielen Dank Tino!!
Gruß
Lenni
AW: muss doch funktionieren!
16.12.2008 19:09:00
Tino
Hallo,
sorry, dass Modul ist beim testen hängen geblieben, kann gelöscht werden.
Das mit dem Hochkomme hat folgende Bewandtnis.
Deine Aufgabenstellung war, die Zahl im Format 0000 anzuzeigen, sind Deine Zellen auf Standard bzw. nicht im Textformat, würde Excel aus 0001 einfach 1 machen.
Durch das Hochkomma wird aus der Zahl ein Text und ich kann es wie gewünscht darstellen
ohne mir Gedanken machen zu müssen welches Format die Zellen haben und in der Zelle selbst wird dieses Hochkomma nicht dargestellt.
Gruß Tino
AW: muss doch funktionieren!
16.12.2008 19:42:15
Lenhard
Hallo Tino!
Es läuft einwandfrei!!! Vielen vielen Dank Tino!!
Danke für Deine weiteren Erklärungen!! ...und dass mit dem Hochkomma ist eine äußerst intelligente Lösung, um ein Format-Durcheinander zu verhindern! Klasse und "Hut ab"!! Außerdem stört es mich nicht!
Vielen Dank nochmals Tino!!
Viele Grüße aus dem nun schon dunklen Norden
Lenni
Wenn du wohl schon alle anderen Probleme...
15.12.2008 00:56:00
Luc:-?
...gelöst zu haben scheinst, Lenni,
kann es ja nur noch um Automatisierung gehen! D.h., du musst dein Nummerierungspgm automatisch aufrufen und zwar aus einer Ereignisprozedur (bitte in VBE-Hilfe nachlesen!). Dazu eignet sich wohl am besten Worksheet_Change (ProzRahmen wird bei Klick auf den richtigen Eintrag im Dokumentklassenmodul-Codeblatt-Menü der betreffenden Tabelle - rechts oben - automatisch generiert!).
Du musst dann nur noch deinen Prozeduraufruf in die freie Zeile eintragen.
Allerdings wird so deine Prozedur bei jeder Änderung des Blattes ausgelöst. Wenn das nicht gewünscht ist, musst du die Art der Änderung vor Aufruf abfragen (kannst du auch in deiner Proz machen und diese ggf ohne Aktion wieder verlassen)...
Gruß Luc :-?
PS: Inwiefern behindert eine Fml in Spalte B andere Auswertungen...?
Besser informiert sein!
AW: Wenn du wohl schon alle anderen Probleme...
15.12.2008 01:06:13
Lenhard
Moin Luc! ... vielen Dank für Deine Ausführlichen Erläuterungen! Ich kann mich aber erst nach einer Runde Schlaf genauer damit auseinander setzen. Aber Deine Hinweise machen mich sehr neugierig!!
Danke für Deinen Link zu den "Nach-Denk-Seiten"!
Ich melde mich auf alle Fälle noch mal! ...es kann nur ein wenig dauern!
Danke nochmals!
Gruß
Lenni
Ja, bitte, lass dir ruhig Zeit... ;-) Gruß owT
15.12.2008 01:16:50
Luc:-?
:-?
AW: Fortlaufende Nummerierung in Spalte per VBA
16.12.2008 04:24:42
peter
Hallo
versuchs mal mit folgender Formel in der Zeille
=SUMME(ZEILE()-1)
ciao Peter
AW: Fortlaufende Nummerierung in Spalte per VBA
18.12.2008 00:25:00
Lenhard
Moin Peter! ...ich schau hier gerade mal wieder "vorbei". Zu Erst: Danke für Deine Teilnahme!! ...aber mit Formeln in Zellen kann ich dass Problem auch lösen! In Excel bin ich schon ein wenig weiter als in VBA...
Nur leider ist eine Formeleinagbe für weitere Prozesse in meiner Datei kontraindiziert. Tino hat mir da mit einer Super-VBA-Lösung geholfen!!! ...und meine mittlerweile weiterentwickelte Datei läuft total gut!!
Aber trotzdem: Dank auch Dir!!
Gruß
Lenni

54 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige