Umschalten von Nummern - Nummern ausschl
07.05.2020 11:54:43
Nummern
ich habe eine Tabelle die Nummern per Schaltfläche generiert (thx an fcs!!!!) und die Uhrzeit, Datum, Bearbeiter ausgibt.
Es dürfen aber nur bestimmte Zahlen generiert werden bzw. einige Zahlen müssen übersprungen werden und es muss einen Stopp geben, sobald ein bestimmter Zahlenblock aufgebraucht ist.
Beispiel:
Zeile 6:
Nr.von Nr. bis Bst. n.freie Nr.
10000 12499 A 10438
..hier müssen z.B. die Zahlen 10455,10456,10457..bis 10468 & 10470 nicht ausgegeben werden. Und die letzte Zahl ist die 12499 - dann müsste eine Fehlermeldung mit einem Hinweistext kommen.
Hat hier jemand eine Idee?
Einen Riesen Dankeschön vorab.
hier für die Schaltflächen (big thx an fcs):
Option Explicit
Sub prcButton_Plus()
'Hochzählen
Dim Zeile As Long
Zeile = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
Call ZaehlenHochRunter(Zeile, bolPlus:=True)
End Sub
Sub prcButton_Minus()
'Runterzählen
Dim Zeile As Long
Zeile = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
Call ZaehlenHochRunter(Zeile, bolPlus:=False)
End Sub
Sub ZaehlenHochRunter(ByVal Zeile, bolPlus As Boolean, _
Optional Spalte As Long = 4)
Dim nummer As Long
With ActiveSheet
With .Cells(Zeile, Spalte)
'.Select 'diese Zeile muss nicht sein, es sei den der Cursor soll dort stehen.
nummer = .Value
nummer = nummer + IIf(bolPlus, 1, -1)
If nummer Mod 100 = 0 Then nummer = nummer + IIf(bolPlus, 1, -1)
.Value = nummer
End With
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim z As Range, rng As Range
On Error GoTo Fehler
Set rng = Range("D:D")
If Not Intersect(rng, Target) Is Nothing Then
rng.Interior.ColorIndex = xlNone
If Target.Row = 1 Then Exit Sub
For Each z In Target
If z.Offset(0, -1) "" Then
Application.EnableEvents = False
z.Offset(0, 2) = Format(Date + Time, "HH:MM:SS" + ", " + "DD.MM.YYYY")
z.Offset(0, 3) = Environ("Username")
z.Interior.Color = vbYellow
End If
Next
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
