Nummerierung

Private Sub Worksheet_Change(ByVal Target As Range) 'Werte in Spalte A nach unten ausfüllen soweit wie Einträge in Spalte C Dim lz As Integer If Not Intersect(Target, Range("C4:C" & Rows.Count)) Is Nothing Then If Cells(Target.Row, 1) = "" Then lz = WorksheetFunction.Max(Cells(Rows.Count, 3).End(xlUp).Row, 4) ' letzte Zeile/min.4 Cells(Target.Row, 1) = WorksheetFunction.Max(Range(Cells(4, 1), Cells(lz, 1))) + 1 End If End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Cordula,
probier mal.
' **********************************************************************
' Modul: Tabelle3 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vTmp As Variant, vLng() As Variant
Dim lngI As Long

If Target.Count = 1 Then
    If Target.Column = 3 And Target.Row > 3 Then
        If Len(Cells(Target.Row, 1)) = 0 Then

            vTmp = Range("A4:A" & Application.Max(Cells(Rows.Count, 1).End(xlUp).Row, 4))

            If Not IsArray(vTmp) Then
                Cells(Target.Row, 1) = Application.Max(Range("A4:A" & _
                    Application.Max(Cells(Rows.Count, 1).End(xlUp).Row, 4))) + 1
                Exit Sub
            End If

            Redim vLng(1 To UBound(vTmp, 1))

            For lngI = 1 To UBound(vTmp, 1)
                If Not IsEmpty(vTmp(lngI, 1)) Then
                    vLng(lngI) = Clng(vTmp(lngI, 1))
                Else
                    vLng(lngI) = ""
                End If
            Next

            QuickSort vLng

            For lngI = 1 To UBound(vLng)
                If vLng(lngI) > lngI Then Exit For
            Next

            Cells(Target.Row, 1) = lngI

        End If
    End If
End If
End Sub
Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant

UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)

P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)

Do

    Do While (data(P1) < T1)
        P1 = P1 + 1
    Loop

    Do While (data(P2) > T1)
        P2 = P2 - 1
    Loop

    If P1 <= P2 Then
        T2 = data(P1)
        data(P1) = data(P2)
        data(P2) = T2
        P1 = P1 + 1
        P2 = P2 - 1
    End If

Loop Until (P1 > P2)

If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread