Geht das auch rückwärts ?

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$E$5" Then Exit Sub Application.EnableEvents = False Range("A1:A14").Copy Range("A2").PasteSpecial (xlPasteValues) Range("A1") = Target With Range("E5") .Value = "" .Select End With Application.EnableEvents = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$E$5" Then Exit Sub If Range("E5").Value <> "999" Then Application.EnableEvents = False Range("A1:A14").Copy Range("A2").PasteSpecial (xlPasteValues) Range("A1") = Target With Range("E5") .Value = "" .Select End With Application.EnableEvents = True Else Application.EnableEvents = False Range("A1").Cut Range("A2:A14").Copy Range("A1").PasteSpecial (xlPasteValues) Range("A1") = Target Range("A14").Delete With Range("E5") .Value = "" .Select End With End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Zaehler As Integer Dim Quersumme As Integer If Target.Address <> "$E$5" Then Exit Sub If Len(Target.Value) <> 3 Then MsgBox "Bitte geben Sie eine 3-stellige Zahl ein" Application.EnableEvents = False With Range("E5") .Value = "" .Select End With Application.EnableEvents = True Exit Sub End If Select Case Target.Value Case 777, 888 Case 999 Application.EnableEvents = False Range("a2:a15").Copy Range("A1").PasteSpecial (xlPasteValues) With Range("E5") .Value = "" .Select End With Application.EnableEvents = True Exit Sub Case Else Quersumme = 0 For Zaehler = 1 To 3 Quersumme = Quersumme + Val(Mid(Target.Value, Zaehler, 1)) Next Zaehler If Quersumme < 19 Then MsgBox "ungültige Quersumme" Application.EnableEvents = False With Range("E5") .Value = "" .Select End With Application.EnableEvents = True Exit Sub End If End Select Application.EnableEvents = False Range("A1:A14").Copy Range("A2").PasteSpecial (xlPasteValues) Range("A1") = Target With Range("E5") .Value = "" .Select End With Application.EnableEvents = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Byte, s As Byte, _ check As Boolean If Target.Address <> "$E$5" Then Exit Sub Application.EnableEvents = False If Application.IsNumber(Target.Value) = False Then MsgBox "Keine numerische Eingabe !" & vbCr & vbCr & "Makro-Abbruch !", _ vbCritical, "Dezenter Hinweis für " & Application.UserName & ":" GoTo ErrorHandler End If Select Case Target.Value Case 777, 888 check = True Case 999 Range("A1:A14").Value = Range("A2:A15").Value Range("A15").ClearContents Case Else If Len(Target.Text) = 3 Then For i = 1 To 3 s = s + Mid(Target.Text, i, 1) Next i If s < 19 Then check = True Else MsgBox "Unzulässiger Wert !" & vbCr & vbCr & "Makro-Abbruch !", _ vbCritical, "Dezenter Hinweis für " & Application.UserName & ":" GoTo ErrorHandler End If Else MsgBox "Dreistellige Zahl erwartet !" & vbCr & vbCr & "Makro-Abbruch !", _ vbCritical, "Dezenter Hinweis für " & Application.UserName & ":" GoTo ErrorHandler End If End Select If check = True Then Range("A2:A15").Value = Range("A1:A14").Value Range("A1") = Target.Value With Range("E5") .Value = "" .Select End With End If ErrorHandler: With Range("E5") .Value = "" .Select End With Application.EnableEvents = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Byte, s As Byte, _ check As Boolean If Target.Address <> "$E$5" Then Exit Sub Application.EnableEvents = False If Application.IsNumber(Target.Value) = False Then MsgBox "Keine numerische Eingabe !" & vbCr & vbCr & "Makro-Abbruch !", _ vbCritical, "Dezenter Hinweis für " & Application.UserName & ":" GoTo ErrorHandler End If Select Case Target.Text Case "777", "888", "000" check = True Case 999 Range("A1:A14").Value = Range("A2:A15").Value Range("A15").ClearContents Case Else If Len(Target.Text) = 3 Then For i = 1 To 3 s = s + Mid(Target.Text, i, 1) Next i If InStr(Target.Text, "7") > 0 Then s = 99 If InStr(Target.Text, "8") > 0 Then s = 99 If InStr(Target.Text, "9") > 0 Then s = 99 If InStr(Target.Text, "0") > 0 Then s = 99 If s < 19 Then check = True Else MsgBox "Unzulässiger Wert !" & vbCr & vbCr & "Makro-Abbruch !", _ vbCritical, "Dezenter Hinweis für " & Application.UserName & ":" GoTo ErrorHandler End If Else MsgBox "Dreistellige Zahl erwartet !" & vbCr & vbCr & "Makro-Abbruch !", _ vbCritical, "Dezenter Hinweis für " & Application.UserName & ":" GoTo ErrorHandler End If End Select If check = True Then Range("A2:A15").Value = Range("A1:A14").Value Range("A1") = Target.Value With Range("E5") .Value = "" .Select End With End If ErrorHandler: With Range("E5") .Value = "" .Select End With Application.EnableEvents = True End Sub

Hallo Werner,
da Du leider nicht die Zeit findest, nach Norddeutschland zu kommen, hast Du vielleicht die Zeit,mir einen Tipp zu geben, wie ich in "unserer" Tabelle (auf einem anderen Blatt) eine Art Datenbank aufbauen kann, in der alle eingegebenen Zahlen (die dreistelligen) der Reihe nach erfasst werden, um danach einige Berechnungen und Statistiken damit durchführen zu können. Die Zahlen sollten mit dazugehörigem Datum/Uhrzeit in einer Tabelle erfasst werden.
Das größte Problem scheint mir dabei zu sein, dass die Zahlen, die über die "999" Funktion wieder gelöscht werden, auch aus der "Datenbank" wieder verschwinden sollten.
Also, wenn Du Zeit und Lust hast (und alle Ostereier gefunden hast), kannst Du Dir ja mal ein paar Gedanken machen, es würde mir sehr helfen.
Gruß aus dem hohen Norden, frohe Ostern
Werner

Hallo Werner,
wenn das letzte Blatt in Deiner Mappe die Datenbank ist, dann wird dort in der Spalte "A" die Zahl, in der Spalte "B" das Datum und in Spalte "C" die Uhrzeit eingetragen.
Diese beiden Makros gehören in ein normales Standard-Modul:
Sub DBKplus()
Dim laR As Long
With Sheets(Sheets.Count)
laR = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(laR + 1, 1).Value = Range("A1").Value
.Cells(laR + 1, 2).Value = Date
.Cells(laR + 1, 3).Value = Time
End With
End Sub
Sub DBKminus()
Dim laR As Long
With Sheets(Sheets.Count)
laR = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(laR, 1), .Cells(laR, 3)).ClearContents
End With
End Sub
Dieses Makro gehört in das Tabellenblatt-Modul des Eingabe-Blattes:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Byte, s As Byte, _
check As Boolean
If Target.Address <> "$E$5" Then Exit Sub
Application.EnableEvents = False
If Application.IsNumber(Target.Value) = False Then
MsgBox "Keine numerische Eingabe !" & vbCr & vbCr & "Makro-Abbruch !", _
vbCritical, "Dezenter Hinweis für " & Application.UserName & ":"
GoTo ErrorHandler
End If
Select Case Target.Text
Case "777", "888", "000"
check = True
Case 999
Range("A1:A14").Value = Range("A2:A15").Value
Range("A15").ClearContents
Call DBKminus
Case Else
If Len(Target.Text) = 3 Then
For i = 1 To 3
s = s + Mid(Target.Text, i, 1)
Next i
If InStr(Target.Text, "7") > 0 Then s = 99
If InStr(Target.Text, "8") > 0 Then s = 99
If InStr(Target.Text, "9") > 0 Then s = 99
If InStr(Target.Text, "0") > 0 Then s = 99
If s < 19 Then
check = True
Else
MsgBox "Unzulässiger Wert !" & vbCr & vbCr & "Makro-Abbruch !", _
vbCritical, "Dezenter Hinweis für " & Application.UserName & ":"
GoTo ErrorHandler
End If
Else
MsgBox "Dreistellige Zahl erwartet !" & vbCr & vbCr & "Makro-Abbruch !", _
vbCritical, "Dezenter Hinweis für " & Application.UserName & ":"
GoTo ErrorHandler
End If
End Select
If check = True Then
Range("A2:A15").Value = Range("A1:A14").Value
Range("A1") = Target.Value
Call DBKplus
End If
ErrorHandler:
With Range("E5")
.ClearContents
.Select
End With
Application.EnableEvents = True
End Sub

Viel Erfolg wünscht
WernerB.

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Geht das auch rückwärts ?

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

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread