Automatische Nummerierung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim avntValues As Variant Dim lngNumber1 As Long, lngNumber2 As Long Dim ialngIndex As Long If Not Intersect(Target, Columns(1)) Is Nothing Then avntValues = Range(Cells(4, 1), Cells(Rows.Count, 1).End(xlUp)).Value For ialngIndex = LBound(avntValues, 1) To UBound(avntValues, 1) If Not IsEmpty(avntValues(ialngIndex, 1)) Then Select Case Left$(avntValues(ialngIndex, 1), 1) Case "A" avntValues(ialngIndex, 1) = "A" & Format$(lngNumber1, "00") lngNumber1 = lngNumber1 + 1 Case "T" avntValues(ialngIndex, 1) = "T" & Format$(lngNumber2, "00") lngNumber2 = lngNumber2 + 1 End Select End If Next Application.EnableEvents = False Range(Cells(4, 1), Cells(Rows.Count, 1).End(xlUp)).Value = avntValues Application.EnableEvents = True End If End Sub

Hallo Jan,
in das Modul der Tabelle fügst du vor Application.EnableEvents = True folgende Zeile ein:

Call Nummerierung(Me)

In ein Standardmodul (Menüleiste-Einfügen-Modul):

Option Explicit

Public Sub Nummerierung(ByRef probjWorksheet As Worksheet)
    Dim lngRow As Long, lngCounter As Long, lngMergeRows As Long
    lngCounter = 1
    With probjWorksheet
        For lngRow = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
            If Not IsEmpty(.Cells(lngRow, 1).Value) Then
                If Left$(.Cells(lngRow, 1).Text, 1) = "A" Or Left$(.Cells(lngRow, 1).Text, 1) = "T" Then
                    If .Cells(lngRow, 1).MergeCells Then
                        For lngMergeRows = lngRow To lngRow + .Cells(lngRow, 1).MergeArea.Rows.Count - 1
                            .Cells(lngMergeRows, 2).Value = lngCounter
                            lngCounter = lngCounter + 1
                        Next
                        lngCounter = 1
                        lngRow = lngRow + .Cells(lngRow, 1).MergeArea.Rows.Count - 1
                    Else
                        .Cells(lngRow, 2).Value = lngCounter
                    End If
                End If
            End If
        Next
    End With
End Sub

Gruß
Nepumuk

Private Sub Worksheet_Change(ByVal Target As Range) Dim zeile As Long, ende As Long Dim wert, präfix, eingabe Dim anzahl As Long If Target.Count > 1 Then Exit Sub If Target.Column = 1 Then If Target.Value "" Then ende = Cells(Rows.Count, 1).End(xlUp).Row wert = wertsuchen(Target) If wert = "" Then Exit Sub präfix = Val(Replace(Target, wert, "")) For zeile = Target.Row + 1 To ende eingabe = Cells(zeile, 1) If Len(eingabe) >= Len(wert) + 1 Then If Left(eingabe, Len(wert)) = wert And IsNumeric(Mid(eingabe, Len(wert) + 1, 1)) _ Then präfix = präfix + 1 Cells(zeile, 1) = wert & Format(präfix, "00") End If End If Next End If End If End Sub Function wertsuchen(text) As Variant Dim anzahl As Long, stelle As Long Dim rückgabe For stelle = 1 To Len(text) If IsNumeric(Mid(text, stelle, 1)) Then Exit For End If Next wertsuchen = Left(text, stelle - 1) End Function

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread