HERBERS Excel-Forum - das Archiv
Bewerten Sie hier bitte das Excel-Portal

Thema: gelöschte Werte zwischenspeichern - VBA | Herbers Excel-Forum

gelöschte Werte zwischenspeichern - VBA
Schorschi

Hallo Forum,
folgenden VBA-Code möchte ich gerne umstellen…
besitze aber nur sehr bescheidene VBA-Kenntnisse
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RaBereich2222 As Range
Dim RaBereich3333 As Range
Set RaBereich2222 = Range("h2:h121")
Set RaBereich3333 = Range("i1:i121")
If Application.Intersect(Target, RaBereich2222) Is Nothing Then Exit Sub
Target.Offset(0, 1).Value = Application.WorksheetFunction.Max(RaBereich3333) + 2
End If
If IsEmpty(Target.Value) Then
Target.Offset(0, 1).Value = ""
End If
End Sub

Erklärung:
Der Startwert befindet sich in der Zelle i1 .
Im RaBereich2222 wird die Menge (Zahlen auch Buchstaben) nach Vergabe erfasst.
Im RaBereich3333 erfolgt automatisch die Vergabe einer Nummer, mit Step + 2 zum Maximalwert.
Die Liste der Namen (= Bereich links neben RaBereich2222) ist in Gruppen
festgelegt und darf nicht verändert werden.
Problem:
Wird nun nachträglich geändert oder storniert, so ändert der Worksheet_Change-Code
diese Nummer mit Step + 2 zum Maximalwert oder löscht sie automatisch.
Die gelöschte Nummer (außer beim letzten Vorgang) wird nicht wieder vergeben,
dies sollte aber nicht sein.
Vorstellung:
Erhalt der Nummer, sie soll beim geänderten Vorgang verbleiben,
und bei Storno an einen anderen, später eingehenden Vorgang vergeben werden.
Lösung: Zwischenspeicherung? Mit späterem Abruf…..
Umsetzung: …?
Beispieldatei:
https://www.herber.de/bbs/user/66823.xls
Vielen Dank für alle Lösungsvorschläge!!
Wünsche noch einen schönen Feiertag und ein schönes Wochenende!
Gruß
Schorschi

AW: gelöschte Werte zwischenspeichern - VBA
Josef

Hallo Schorschi,
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim lngNextNumber, lngMax As Long, lngMin As Long
  Dim RaBereich2222 As Range
  Dim RaBereich3333 As Range
  
  Set RaBereich2222 = Range("h2:h121")
  Set RaBereich3333 = Range("i1:i121")
  
  If Intersect(Target, RaBereich2222) Is Nothing Then Exit Sub
  
  If IsEmpty(Target.Value) Then
    Target.Offset(0, 1) = ""
  Else
    
    With Application
      lngMin = Range("I1")
      lngMax = .Max(RaBereich3333) + 2
      For lngNextNumber = lngMin To lngMax Step 2
        If .CountIf(RaBereich3333, lngNextNumber) = 0 Then Exit For
      Next
      Target.Offset(0, 1) = lngNextNumber
    End With
  End If
  
  Set RaBereich2222 = Nothing
  Set RaBereich3333 = Nothing
End Sub


Gruß Sepp

super genial... Vielen Dank!
Schorschi

Hallo Sepp,
vielen herzlichen Dank für die Hilfe und Lösung.
Es funktioniert perfekt!!
Ich wünsche Dir einen schönen Sonntag,
einen guten Rutsch und ALLES GUTE für das neue Jahr!!
Gruß
Schorschi