Welcome, guest! Login / Register - Why register?
Psst.. new poll here.
Psst.. new forums here.
Microsoft is blocking us again (TY IP Reputation!) so just use oauth login instead. :)

Paste

Pasted by JohnBoy ( 15 years ago )
' Sub für die Ausgabe
Private Sub ausgegeben_Click()

' Die unterste freie Zelle von Spalte E wird gesucht ...
Cells(65000, 5).End(xlUp).Offset(1, 0).Select
' ... und die eingegebene Schlüsselnummer wird dort eingegeben
Range(ActiveCell.Address) = Range("B3")

' Rechts daneben wird der zugehörige Name eingetragen.
ActiveCell.Offset(0, 1).Value = Range("D3")

' Und noch in die Zeile nochmal rechts daneben wird ein Timestamp eingefuegt.
ActiveCell.Offset(0, 2).NumberFormat = "dd mmm yyyy hh:mm:ss"
ActiveCell.Offset(0, 2).Value = Now

' Es wird nach der Schluesselnummer in Spalte E gesucht um diese ggf. dort zu entfernen.
Dim rwindex As Long
For rwindex = 40 To Cells(65356, 2).End(xlUp).Row
    If Cells(rwindex, 2).Value = Range("B3").Value Then
        Cells(rwindex, 2).Value = ""
        Cells(rwindex, 2).Offset(0, 1).Value = ""
        Exit For
    End If
Next rwindex

' Anschließed werden von der ermittelt Position bis zu Zeile 500 alle IDs um Timestamps um eine Position nach oben geschoben, um die entstandene Luecke aufzufuellen.
Dim replace_index As Long
For replace_index = rwindex To 500
    Cells(replace_index, 2).Value = Cells(replace_index + 1, 2)
    Cells(replace_index, 2).Offset(0, 1).Value = Cells(replace_index + 1, 2).Offset(0, 1)
Next replace_index

' Schließlich werden die Eingabefelder geleert.
Range("B3").Value = ""
Range("D3").Value = ""

End Sub



' Sub für das Löschen aus dem Schrank
Private Sub ausSchrankLoeschen_Click()

' Es wird nach der Schluesselnummer in Spalte E gesucht um diese dort zu entfernen ...
Dim rwindex As Long
For rwindex = 17 To Cells(65356, 2).End(xlUp).Row
    If Cells(rwindex, 2).Value = Range("I3").Value Then
        Cells(rwindex, 2).Value = ""
        Exit For
    End If
Next rwindex

' Anschließed werden von der ermittelt Position bis zu Zeile 500 alle IDs um Timestamps um eine Position nach oben geschoben, um die entstandene Luecke aufzufuellen.
Dim replace_index As Long
For replace_index = rwindex To 500
    Cells(replace_index, 2).Value = Cells(replace_index + 1, 2)
    Cells(replace_index, 2).Offset(0, 1).Value = Cells(replace_index + 1, 2).Offset(0, 1)
Next replace_index

End Sub

 

Revise this Paste

Your Name: Code Language: