Fehlende Nummern ermitteln

Hallo,
hab folgendes Problem mit folgendem Code:


Sub Nummauffuellen()
' hier wird eine Liste von nicht mehr als
' 9999 Zeilen angenommen. Man kann natürlich auch
' anders vorgehen, indem man ohne feste Listengrösse
' auskommt, dann weiss man aber nicht, wie gross die
' Variable "W" dimensioniert werden muss. Entweder vergrössert
' man sie dann durch "Redim", oder setzt sie gleich zu
' Anfang auf eine bestimmte Grösse. Dann kann man aber
' auch gleich dieses Makro hier ungeändert verwenden.
' Eine weitere Möglichkeit besteht darin, die errechneten
' freien Zahlen direkt in die entsprechenden Zellen zu
' schreiben. In diesem Falle müsste eine "Zeilenvariable"
' hochgezählt werden, was sicherlich zugunsten des
' Arbeitsspeichers wäre. Aber davon haben wir ja alle
' genug. :-)
Dim i As Integer
Dim Ende As Integer
Dim W(1 To 9999) As Integer
Dim Y As Integer
Dim x As Integer
Range("A2").Select
Ende = Application.WorksheetFunction.Max(ActiveCell.EntireColumn)
Zähler = 0
Y = 0
For i = 2 To Ende
If Cells(i, 1).Value = "" Then
Exit For
End If
Y = Cells(i - 1, 1).Value + 1
If Cells(i, 1).Value  Y Then
Do
Zähler = Zähler + 1
W(Zähler) = Y
Y = Y + 1
Loop Until Y = Cells(i, 1).Value
End If
Next i
' Jetzt werden die freien Nummern in Spalte "B" geschrieben:
Range("B2").Select
For x = 1 To Zähler
Cells(x + 1, 2).Value = W(x)
Next
End 

Sub
Hier meine Beispieldatei:
https://www.herber.de/bbs/user/54321.xls
Bei der Ausführung kommt es immer zu einem Laufzeitfehler 6, Überlauf!
Kann leider den Grund hierfür nicht finden, wäre toll wenn sich das jemand mal hier angucken kö _
nnte.
Gruß
Sascha

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

HAllo
Hab reingeguckt und bin nicht raus schlau geworden.
Was willst du ermitteln?
Ich denke mal die Fehlenden Zahlen.
Wenn dem so ist, versuch mal dies:

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Sub Nummauffuellen()
Dim bereich As Range
Dim Mn As Long
Dim Mx As Long
Dim L As Long
Dim I As Long
Set bereich = Range("A2", Range("A65536").End(xlUp))
MsgBox bereich.Address
Mx = Application.Max(bereich)
Mn = Application.Min(bereich)
For L = Mn To Mx
    If WorksheetFunction.CountIf(bereich, L) = 0 Then
        I = I + 1
        Cells(I, 2) = L
    End If
Next
End Sub

Wenn nicht, beschreib nochmal was gewollt ist.
ransi

Sub Neuu() Dim lngMin As Long, lngMax As Long, lngI As Long, lngN As Long Dim rngNr As Range With ActiveWorkbook.ActiveSheet lngMax = Application.WorksheetFunction.Max(.Range("A:A")) lngMin = Application.WorksheetFunction.Min(.Range("A:A")) lngN = 2 For lngI = lngMin To lngMax Set rngNr = .Range("A:A").Find(What:=lngI) If rngNr Is Nothing Then .Cells(lngN, 2) = lngI lngN = lngN + 1 End If Set rngNr = Nothing Next lngI End With End Sub

Sub Neuu() Dim lngMin As Long, lngMax As Long, lngI As Long, lngN As Long Dim rngNr As Range Dim wksSource As Worksheet, wksTarget As Worksheet ' Hier kannst du nun Quelle und Ziel beliebig anpassen. Set wksSource = Workbooks("40100.xls").Worksheets("Tabelle1") Set wksTarget = Workbooks("40100.xls").Worksheets("Tabelle2") With wksSource lngMax = Application.WorksheetFunction.Max(.Range("A:A")) lngMin = Application.WorksheetFunction.Min(.Range("A:A")) lngN = 2 For lngI = lngMin To lngMax Set rngNr = .Range("A:A").Find(What:=lngI) If rngNr Is Nothing Then wksTarget.Cells(lngN, 2) = lngI lngN = lngN + 1 End If Set rngNr = Nothing Next lngI End With End Sub

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread